put_ bh idinfo
put_ bh (IfaceForeign ae af) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh a1
put_ bh a2
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh a8
- put_ bh (IfaceSyn aq ar as at) = do
+ put_ bh (IfaceSyn aq ar as) = do
putByte bh 3
put_ bh aq
put_ bh ar
put_ bh as
- put_ bh at
- put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do
putByte bh 4
put_ bh a1
put_ bh a2
put_ bh a4
put_ bh a5
put_ bh a6
- put_ bh a7
get bh = do
h <- getByte bh
case h of
a5 <- get bh
a6 <- get bh
a7 <- get bh
- a8 <- get bh
- return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
+ return (IfaceData a1 a2 a3 a4 a5 a6 a7)
3 -> do
aq <- get bh
ar <- get bh
as <- get bh
- at <- get bh
- return (IfaceSyn aq ar as at)
+ return (IfaceSyn aq ar as)
_ -> do
a1 <- get bh
a2 <- get bh
a4 <- get bh
a5 <- get bh
a6 <- get bh
- a7 <- get bh
- return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
+ return (IfaceClass a1 a2 a3 a4 a5 a6)
instance Binary IfaceInst where
put_ bh (IfaceInst cls tys dfun flag orph) = do
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
isRecursiveTyCon, tyConArity,
- ArgVrcs, AlgTyConRhs(..), newTyConRhs )
+ AlgTyConRhs(..), newTyConRhs )
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
\begin{code}
------------------------------------------------------
-buildSynTyCon name tvs rhs_ty arg_vrcs
- = mkSynTyCon name kind tvs rhs_ty arg_vrcs
+buildSynTyCon name tvs rhs_ty
+ = mkSynTyCon name kind tvs rhs_ty
where
kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
buildAlgTyCon :: Name -> [TyVar]
-> ThetaType -- Stupid theta
-> AlgTyConRhs
- -> ArgVrcs -> RecFlag
+ -> RecFlag
-> Bool -- True <=> want generics functions
-> Bool -- True <=> was declared in GADT syntax
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics gadt_syn
- = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+ = do { let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta
rhs fields is_rec want_generics gadt_syn
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; fields = mkTyConSelIds tycon rhs
buildClass :: Name -> [TyVar] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [(Name, DefMeth, Type)] -- Method info
- -> RecFlag -> ArgVrcs -- Info for type constructor
+ -> RecFlag -- Info for type constructor
-> TcRnIf m n Class
-buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs
+buildClass class_name tvs sc_theta fds sig_stuff tc_isrec
= do { tycon_name <- newImplicitBinder class_name mkClassTyConOcc
; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
-- The class name is the 'parent' for this datacon, not its tycon,
; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; tycon = mkClassTyCon tycon_name clas_kind tvs
- tc_vrcs rhs rec_clas tc_isrec
+ rhs rec_clas tc_isrec
-- 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 }
import NewDemand ( StrictSig, pprIfaceStrictSig )
import TcType ( deNoteType )
import Class ( FunDep, DefMeth, pprFundeps )
-import TyCon ( ArgVrcs )
import OccName ( OccName, parenSymOcc, occNameFS,
OccSet, unionOccSets, unitOccSet )
import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
- ifVrcs :: ArgVrcs,
ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax
ifGeneric :: Bool -- True <=> generic converter functions available
} -- We need this for imported data decls, since the
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifVrcs :: ArgVrcs,
ifSynRhs :: IfaceType -- synonym expansion
}
ifTyVars :: [IfaceTvBndr], -- Type variables
ifFDs :: [FunDep FastString], -- Functional dependencies
ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
- ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
+ ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
}
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (vcat [equals <+> ppr mono_ty,
- pprVrcs vrcs])
+ 4 (equals <+> ppr mono_ty)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec, ifVrcs = vrcs})
+ ifRec = isrec})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
+ 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls])
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
+ ifFDs = fds, ifSigs = sigs, ifRec = isrec})
= hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
- 4 (vcat [pprVrcs vrcs,
- pprRec isrec,
+ 4 (vcat [pprRec isrec,
sep (map ppr sigs)])
-pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
= bool (ifName d1 == ifName d2 &&
ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2 &&
ifGadtSyntax d1 == ifGadtSyntax d2 &&
ifGeneric d1 == ifGeneric d2) &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
= bool (ifName d1 == ifName d2 &&
- ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2) &&&
+ ifRec d1 == ifRec d2) &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
import TyCon ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
- tyConHasGenerics, tyConArgVrcs, synTyConRhs, isGadtSyntaxTyCon,
+ tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
ifTyVars = toIfaceTvBndrs clas_tyvars,
ifFDs = map toIfaceFD clas_fds,
ifSigs = map toIfaceClassOp op_stuff,
- ifRec = boolToRecFlag (isRecursiveTyCon tycon),
- ifVrcs = tyConArgVrcs tycon }
+ ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
where
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
tycon = classTyCon clas
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifVrcs = tyConArgVrcs tycon,
ifSynRhs = toIfaceType ext syn_ty }
| isAlgTyCon tycon
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifVrcs = tyConArgVrcs tycon,
ifGeneric = tyConHasGenerics tycon }
| isForeignTyCon tycon
ifCons = IfAbstractTyCon,
ifGadtSyntax = False,
ifGeneric = False,
- ifRec = NonRecursive,
- ifVrcs = tyConArgVrcs tycon }
+ ifRec = NonRecursive}
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
- ifVrcs = arg_vrcs, ifRec = is_rec,
+ ifRec = is_rec,
ifGeneric = want_generic })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
- cons arg_vrcs is_rec want_generic gadt_syn
+ cons is_rec want_generic gadt_syn
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
}}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
+ ifSynRhs = rdr_rhs_ty})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_ty <- tcIfaceType rdr_rhs_ty
- ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
+ ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
}
tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
ifFDs = rdr_fds, ifSigs = rdr_sigs,
- ifVrcs = tc_vrcs, ifRec = tc_isrec })
+ ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mappM tc_sig rdr_sigs
; fds <- mappM tc_fd rdr_fds
- ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
+ ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
- liftedTypeKind 0 [])) }
+ liftedTypeKind 0)) }
tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
import Var ( TyVar, mkTyVar )
import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
import OccName ( mkOccNameFS, tcName, mkTyVarOcc )
-import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon,
+import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
PrimRep(..) )
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unliftedTypeKind, unboxedTypeKind,
openAlphaTyVars@(openAlphaTyVar:_) = tyVarList openTypeKind
openAlphaTy = mkTyVarTy openAlphaTyVar
-
-vrcPos,vrcZero :: (Bool,Bool)
-vrcPos = (True,False)
-vrcZero = (False,False)
-
-vrcsP,vrcsZ,vrcsZP :: ArgVrcs
-vrcsP = [vrcPos]
-vrcsZ = [vrcZero]
-vrcsZP = [vrcZero,vrcPos]
\end{code}
\begin{code}
-- only used herein
-pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon
-pcPrimTyCon name arg_vrcs rep
- = mkPrimTyCon name kind arity arg_vrcs rep
+pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon
+pcPrimTyCon name arity rep
+ = mkPrimTyCon name kind arity rep
where
- arity = length arg_vrcs
kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
result_kind = case rep of
PtrRep -> unliftedTypeKind
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
- = mkPrimTyCon name result_kind 0 [] rep
+ = mkPrimTyCon name result_kind 0 rep
where
result_kind = case rep of
PtrRep -> unliftedTypeKind
\begin{code}
mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
-statePrimTyCon = pcPrimTyCon statePrimTyConName vrcsZ VoidRep
+statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
RealWorld; it's only used in the type system, to parameterise State#.
\begin{code}
-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 [] PtrRep
+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep
realWorldTy = mkTyConTy realWorldTyCon
realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld
\end{code}
%************************************************************************
\begin{code}
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName vrcsP PtrRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName vrcsZP PtrRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName vrcsZ PtrRep
-byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep
+byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt]
byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon
%************************************************************************
\begin{code}
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP AddrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
\end{code}
%************************************************************************
\begin{code}
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP PtrRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
\end{code}
%************************************************************************
\begin{code}
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP PtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
\end{code}
pcNonRecDataTyCon = pcTyCon False NonRecursive
pcRecDataTyCon = pcTyCon False Recursive
-pcTyCon is_enum is_rec name tyvars argvrcs cons
+pcTyCon is_enum is_rec name tyvars cons
= tycon
where
tycon = mkAlgTyCon name
(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
tyvars
- argvrcs
[] -- No stupid theta
(DataTyCon cons is_enum)
[] -- No record selectors
\begin{code}
charTy = mkTyConTy charTyCon
-charTyCon = pcNonRecDataTyCon charTyConName [] [] [charDataCon]
+charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon]
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy = mkListTy charTy -- convenience only
\begin{code}
intTy = mkTyConTy intTyCon
-intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon]
+intTyCon = pcNonRecDataTyCon intTyConName [] [intDataCon]
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
\end{code}
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon]
+floatTyCon = pcNonRecDataTyCon floatTyConName [] [floatDataCon]
floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
\end{code}
\begin{code}
doubleTy = mkTyConTy doubleTyCon
-doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon]
+doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [doubleDataCon]
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
\end{code}
boolTy = mkTyConTy boolTyCon
boolTyCon = pcTyCon True NonRecursive boolTyConName
- [] [] [falseDataCon, trueDataCon]
+ [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConName [] [] boolTyCon
trueDataCon = pcDataCon trueDataConName [] [] boolTyCon
mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
-listTyCon = pcRecDataTyCon listTyConName
- alpha_tyvar [(True,False)] [nilDataCon, consDataCon]
+listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon]
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon = pcDataConWithFixity True {- Declared infix -}
-- `PrelPArr'.
--
parrTyCon :: TyCon
-parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [(True, False)] [parrDataCon]
+parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon]
parrDataCon :: DataCon
parrDataCon = pcDataCon
| otherwise
= pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
+ mkPrimTyCon tc_name kind 0 VoidRep
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
- tcExtendRecEnv, tcLookupTyVar )
-import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
+ tcExtendRecEnv, tcLookupTyVar, InstInfo )
+import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
import Kind ( mkArrowKinds, splitKindFunTys )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
-import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
+import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
import DataCon ( DataCon, dataConWrapId, dataConName,
to check all the side conditions on validity. We could not
do this before because we were in a mutually recursive knot.
-
+Identification of recursive TyCons
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
-@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
+@TyThing@s.
+
+Identifying a TyCon as recursive serves two purposes
+
+1. Avoid infinite types. Non-recursive newtypes are treated as
+"transparent", like type synonyms, after the type checker. If we did
+this for all newtypes, we'd get infinite types. So we figure out for
+each newtype whether it is "recursive", and add a coercion if so. In
+effect, we are trying to "cut the loops" by identifying a loop-breaker.
+
+2. Avoid infinite unboxing. This is nothing to do with newtypes.
+Suppose we have
+ data T = MkT Int T
+ f (MkT x t) = f t
+Well, this function diverges, but we don't want the strictness analyser
+to diverge. But the strictness analyser will diverge because it looks
+deeper and deeper into the structure of T. (I believe there are
+examples where the function does something sane, and the strictness
+analyser still diverges, but I can't see one now.)
+
+Now, concerning (1), the FC2 branch currently adds a coercion for ALL
+newtypes. I did this as an experiment, to try to expose cases in which
+the coercions got in the way of optimisations. If it turns out that we
+can indeed always use a coercion, then we don't risk recursive types,
+and don't need to figure out what the loop breakers are.
+
+For newtype *families* though, we will always have a coercion, so they
+are always loop breakers! So you can easily adjust the current
+algorithm by simply treating all newtype families as loop breakers (and
+indeed type families). I think.
\begin{code}
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
-- Kind-check the declarations
{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
- ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
- ; calc_rec = calcRecFlags boot_details rec_alg_tyclss
- ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) }
+ ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss
+ ; tc_decl = addLocM (tcTyClDecl calc_rec) }
-- Type-check the type synonyms, and extend the envt
- ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
+ ; syn_tycons <- tcSynDecls kc_syn_decls
; tcExtendGlobalEnv syn_tycons $ do
-- Type-check the data types and classes
%************************************************************************
\begin{code}
-tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
-tcSynDecls calc_vrcs [] = return []
-tcSynDecls calc_vrcs (decl : decls)
- = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
- ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
+tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
+tcSynDecls [] = return []
+tcSynDecls (decl : decls)
+ = do { syn_tc <- addLocM tcSynDecl decl
+ ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
; return (syn_tc : syn_tcs) }
-tcSynDecl calc_vrcs
+tcSynDecl
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "tcd1" <+> ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
- ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }
+ ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) }
--------------------
-tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
- -> TyClDecl Name -> TcM TyThing
+tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing
-tcTyClDecl calc_vrcs calc_isrec decl
- = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
+tcTyClDecl calc_isrec decl
+ = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
-tcTyClDecl1 calc_vrcs calc_isrec
+tcTyClDecl1 calc_isrec
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
= tcTyVarBndrs tvs $ \ tvs' -> do
DataType -> mkDataTyConRhs data_cons
NewType -> ASSERT( isSingleton data_cons )
mkNewTyConRhs tycon (head data_cons)
- ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec
+ ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
(want_generic && canDoGenerics data_cons)
})
; return (ATyCon tycon)
}
where
- arg_vrcs = calc_vrcs tc_name
is_rec = calc_isrec tc_name
h98_syntax = case cons of -- All constructors have same shape
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
other -> True
-tcTyClDecl1 calc_vrcs calc_isrec
+tcTyClDecl1 calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
tcdCtxt = ctxt, tcdMeths = meths,
tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
-- need to look up its recursiveness and variance
tycon_name = tyConName (classTyCon clas)
tc_isrec = calc_isrec tycon_name
- tc_vrcs = calc_vrcs tycon_name
in
buildClass class_name tvs' ctxt' fds'
- sig_stuff tc_isrec tc_vrcs)
+ sig_stuff tc_isrec)
; return (AClass clas) }
where
tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
; return (tvs1', tvs2') }
-tcTyClDecl1 calc_vrcs calc_isrec
+tcTyClDecl1 calc_isrec
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
- = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
+ = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0))
-----------------------------------
tcConDecl :: Bool -- True <=> -funbox-strict_fields
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
%
-Analysis functions over data types. Specficially
- a) detecting recursive types
- b) computing argument variances
+Analysis functions over data types. Specficially, detecting recursive types.
This stuff is only used for source-code decls; it's recorded in interface
files for imported data types.
\begin{code}
module TcTyDecls(
- calcTyConArgVrcs,
calcRecFlags,
calcClassCycles, calcSynCycles
) where
import RnHsSyn ( extractHsTyNames )
import Type ( predTypeRep, tcView )
import HscTypes ( TyThing(..), ModDetails(..) )
-import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
+import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
synTyConDefn, isSynTyCon, isAlgTyCon,
- tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
+ tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
import Var ( TyVar )
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
\end{code}
-
-
-%************************************************************************
-%* *
- Compuing TyCon argument variances
-%* *
-%************************************************************************
-
-Computing the tyConArgVrcs info
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
-tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
-separately. Note that this is information about occurrences of type
-variables, not usages of term variables.
-
-The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
-syntycons only* such that all tycons referred to (by mutual recursion)
-appear in the list. The fixpointing will be done on this set of
-tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
-be (knot-tyingly?) stuck back into the appropriate fields.
-
-\begin{code}
-calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
--- Gives arg variances for TyCons,
--- including the class TyCon of a class
-calcTyConArgVrcs tyclss
- = get_vrc
- where
- tycons = map getTyCon tyclss
-
- -- We should only look up things that are in the map
- get_vrc n = case lookupNameEnv final_oi n of
- Just (_, pms) -> pms
- Nothing -> pprPanic "calcVrcs" (ppr n)
-
- -- We are going to fold over this map,
- -- so we need the TyCon in the range
- final_oi :: NameEnv (TyCon, ArgVrcs)
- final_oi = tcaoFix initial_oi
-
- initial_oi :: NameEnv (TyCon, ArgVrcs)
- initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
- | tc <- tycons]
- initial tc = replicate (tyConArity tc) (False,False)
-
- tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
- -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
- tcaoFix oi
- | changed = tcaoFix oi'
- | otherwise = oi'
- where
- (changed,oi') = foldNameEnv iterate (False,oi) oi
-
- iterate (tc, pms) (changed,oi')
- = (changed || (pms /= pms'),
- extendNameEnv oi' (tyConName tc) (tc, pms'))
- where
- pms' = tcaoIter oi' tc -- seq not simult
-
- tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
- -> TyCon -- tycon to update
- -> ArgVrcs -- new ArgVrcs for tycon
-
- tcaoIter oi tc | isAlgTyCon tc
- = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
- where
- data_cons = tyConDataCons tc
- vs = tyConTyVars tc
- argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
-
- tcaoIter oi tc | isSynTyCon tc
- = let (tyvs,ty) = synTyConDefn tc
- -- we use the already-computed result for tycons not in this SCC
- in map (\v -> vrcInTy (lookup oi) v ty) tyvs
-
- lookup oi tc = case lookupNameEnv oi (tyConName tc) of
- Just (_, pms) -> pms
- Nothing -> tyConArgVrcs tc
- -- We use the already-computed result for tycons not in this SCC
-\end{code}
-
-
-Variance of tyvars in a type
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-A general variance-check function. We pass a function for determining
-the @ArgVrc@s of a tycon; when fixpointing this refers to the current
-value; otherwise this should be looked up from the tycon's own
-tyConArgVrcs. Again, it knows the representation of Types.
-
-\begin{code}
-vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
- -> TyVar -- tyvar to check Vrcs of
- -> Type -- type to check for occ in
- -> (Bool,Bool) -- (occurs positively, occurs negatively)
-
-vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
- then vrcInTy fao v ty
- else (False,False)
- -- note that ftv cannot be calculated as occPos||occNeg,
- -- since if a tyvar occurs only as unused tyconarg,
- -- occPos==occNeg==False, but ftv=True
-
-vrcInTy fao v (TyVarTy v') = if v==v'
- then (True,False)
- else (False,False)
-
-vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
- then (True,True)
- else vrcInTy fao v ty1
- -- ty1 is probably unknown (or it would have been beta-reduced);
- -- hence if v occurs in ty2 at all then it could occur with
- -- either variance. Otherwise it occurs as it does in ty1.
-
-vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
- `orVrc`
- vrcInTy fao v ty2
-
-vrcInTy fao v (ForAllTy v' ty) = if v==v'
- then (False,False)
- else vrcInTy fao v ty
-
-vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
- pms2 = fao tc
- in orVrcs (zipWith timesVrc pms1 pms2)
-
-vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
-\end{code}
-
-Variance algebra
-~~~~~~~~~~~~~~~~
-
-\begin{code}
-orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
-orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
-
-orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
-orVrcs = foldl orVrc (False,False)
-
-negVrc :: (Bool,Bool) -> (Bool,Bool)
-negVrc (p1,m1) = (m1,p1)
-
-anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
-anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
- (False,False) as
-
-timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
-timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
- p1 && m2 || m1 && p2)
-\end{code}
\begin{code}
module TyCon(
- TyCon, ArgVrcs, FieldLabel,
+ TyCon, FieldLabel,
PrimRep(..),
tyConPrimRep,
tyConKind,
tyConUnique,
tyConTyVars,
- tyConArgVrcs,
algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
tyConSelIds,
tyConStupidTheta,
tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon
-- (b) the cached types in AlgTyConRhs.NewTyCon
-- But not over the data constructors
- argVrcs :: ArgVrcs,
-
algTcSelIds :: [Id], -- Its record selectors (empty if none):
algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
- synTcRhs :: Type, -- Right-hand side, mentioning these type vars.
+ synTcRhs :: Type -- Right-hand side, mentioning these type vars.
-- Acts as a template for the expansion when
-- the tycon is applied to some types.
- argVrcs :: ArgVrcs
}
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
- argVrcs :: ArgVrcs,
primTyConRep :: PrimRep,
-- Many primitive tycons are unboxed, but some are
type FieldLabel = Name
-type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)]
- -- [] means "no information, assume the worst"
-
data AlgTyConRhs
= AbstractTyCon -- We know nothing about this data type, except
-- that it's represented by a pointer
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs sel_ids is_rec gen_info gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
- argVrcs = argvrcs,
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcSelIds = sel_ids,
hasGenerics = gen_info
}
-mkClassTyCon name kind tyvars argvrcs rhs clas is_rec
+mkClassTyCon name kind tyvars rhs clas is_rec
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
- argVrcs = argvrcs,
algTcStupidTheta = [],
algTcRhs = rhs,
algTcSelIds = [],
-- as primitive, but *lifted*, TyCons for now. They are lifted
-- because the Haskell type T representing the (foreign) .NET
-- type T is actually implemented (in ILX) as a thunk<T>
-mkForeignTyCon name ext_name kind arity arg_vrcs
+mkForeignTyCon name ext_name kind arity
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = arity,
- argVrcs = arg_vrcs,
primTyConRep = PtrRep, -- they all do
isUnLifted = False,
tyConExtName = ext_name
-- most Prim tycons are lifted
-mkPrimTyCon name kind arity arg_vrcs rep
- = mkPrimTyCon' name kind arity arg_vrcs rep True
+mkPrimTyCon name kind arity rep
+ = mkPrimTyCon' name kind arity rep True
-mkVoidPrimTyCon name kind arity arg_vrcs
- = mkPrimTyCon' name kind arity arg_vrcs VoidRep True
+mkVoidPrimTyCon name kind arity
+ = mkPrimTyCon' name kind arity VoidRep True
-- but RealWorld is lifted
-mkLiftedPrimTyCon name kind arity arg_vrcs rep
- = mkPrimTyCon' name kind arity arg_vrcs rep False
+mkLiftedPrimTyCon name kind arity rep
+ = mkPrimTyCon' name kind arity rep False
-mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted
+mkPrimTyCon' name kind arity rep is_unlifted
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = arity,
- argVrcs = arg_vrcs,
primTyConRep = rep,
isUnLifted = is_unlifted,
tyConExtName = Nothing
}
-mkSynTyCon name kind tyvars rhs argvrcs
+mkSynTyCon name kind tyvars rhs
= SynTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
- synTcRhs = rhs,
- argVrcs = argvrcs
+ synTcRhs = rhs
}
mkCoercionTyCon name arity kindRule
tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
\end{code}
-@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for
-each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is
-actually computed (in another file).
-
-\begin{code}
-tyConArgVrcs :: TyCon -> ArgVrcs
-tyConArgVrcs (FunTyCon {}) = [(False,True),(True,False)]
-tyConArgVrcs (AlgTyCon {argVrcs = oi}) = oi
-tyConArgVrcs (PrimTyCon {argVrcs = oi}) = oi
-tyConArgVrcs (TupleTyCon {tyConArity = arity}) = (replicate arity (True,False))
-tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi
-\end{code}
-
\begin{code}
synTyConDefn :: TyCon -> ([TyVar], Type)
synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty)
mkCoercionTyCon eqCoercionKindTyConName 2 (\ _ -> coSuperKind)
mkKindTyCon :: Name -> TyCon
-mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 []
+mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0
--------------------------
-- ... and now their names