applyTy, applyTys, isForAllTy,
-- Source types
- SourceType(..), sourceTypeRep,
+ SourceType(..), sourceTypeRep, mkPredTy, mkPredTys,
-- Newtypes
splitNewType_maybe,
-- Lifting and boxity
- isUnLiftedType, isUnboxedTupleType, isAlgType,
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
usageAnnOfType, typeKind, addFreeTyVars,
-- Tidying up for printing
- tidyType, tidyTypes,
- tidyOpenType, tidyOpenTypes,
- tidyTyVar, tidyTyVars, tidyFreeTyVars,
- tidyTopType, tidyPred,
+ tidyType, tidyTypes,
+ tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyFreeTyVars,
+ tidyOpenTyVar, tidyOpenTyVars,
+ tidyTopType, tidyPred,
-- Comparison
eqType, eqKind, eqUsage,
import Name ( NamedThing(..), mkLocalName, tidyOccName )
import Class ( classTyCon )
-import TyCon ( TyCon, isRecursiveTyCon,
+import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
)
-- others
+import CmdLineOpts ( opt_DictsStrict )
import Maybes ( maybeToBool )
import SrcLoc ( noSrcLoc )
import PrimRep ( PrimRep(..) )
~~~~~
\begin{code}
-mkSynTy syn_tycon tys
- = ASSERT( isSynTyCon syn_tycon )
- ASSERT( length tyvars == length tys )
- NoteTy (SynNote (TyConApp syn_tycon tys))
- (substTyWith tyvars tys body)
+mkSynTy tycon tys
+ | n_args == arity -- Exactly saturated
+ = mk_syn tys
+ | n_args > arity -- Over-saturated
+ = foldl AppTy (mk_syn (take arity tys)) (drop arity tys)
+ | otherwise -- Un-saturated
+ = TyConApp tycon tys
+ -- For the un-saturated case we build TyConApp directly
+ -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon).
+ -- Here we are relying on checkValidType to find
+ -- the error. What we can't do is use mkSynTy with
+ -- too few arg tys, because that is utterly bogus.
+
where
- (tyvars, body) = getSynTyConDefn syn_tycon
+ mk_syn tys = NoteTy (SynNote (TyConApp tycon tys))
+ (substTyWith tyvars tys body)
+
+ (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon
+ arity = tyConArity tycon
+ n_args = length tys
\end{code}
Notes on type synonyms
(b) synonyms
(c) predicates
(d) usage annotations
+ (e) [recursive] newtypes
It's useful in the back end.
+Remember, non-recursive newtypes get expanded as part of the SourceTy case,
+but recursive ones are represented by TyConApps and have to be expanded
+by steam.
+
\begin{code}
repType :: Type -> Type
-repType (ForAllTy _ ty) = repType ty
-repType (NoteTy _ ty) = repType ty
-repType (SourceTy p) = repType (sourceTypeRep p)
-repType (UsageTy _ ty) = repType ty
-repType ty = ty
+repType (ForAllTy _ ty) = repType ty
+repType (NoteTy _ ty) = repType ty
+repType (SourceTy p) = repType (sourceTypeRep p)
+repType (UsageTy _ ty) = repType ty
+repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc
+ = repType (newTypeRep tc tys)
+repType ty = ty
splitRepFunTys :: Type -> ([Type], Type)
-- Like splitFunTys, but looks through newtypes and for-alls
The key function is sourceTypeRep which gives the representation of a source type:
\begin{code}
+mkPredTy :: PredType -> Type
+mkPredTy pred = SourceTy pred
+
+mkPredTys :: ThetaType -> [Type]
+mkPredTys preds = map SourceTy preds
+
sourceTypeRep :: SourceType -> Type
-- Convert a predicate to its "representation type";
-- the type of evidence for that predicate, which is actually passed at runtime
Free variables of a type
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-
tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
It doesn't change the uniques at all, just the print names.
\begin{code}
-tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVar env@(tidy_env, subst) tyvar
- = case lookupVarEnv subst tyvar of
-
- Just tyvar' -> -- Already substituted
- (env, tyvar')
-
- Nothing -> -- Make a new nice name for it
-
- case tidyOccName tidy_env (getOccName name) of
- (tidy', occ') -> -- New occname reqd
- ((tidy', subst'), tyvar')
- where
- subst' = extendVarEnv subst tyvar tyvar'
- tyvar' = setTyVarName tyvar name'
- name' = mkLocalName (getUnique name) occ' noSrcLoc
- -- Note: make a *user* tyvar, so it printes nicely
- -- Could extract src loc, but no need.
+tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyVarBndr (tidy_env, subst) tyvar
+ = case tidyOccName tidy_env (getOccName name) of
+ (tidy', occ') -> -- New occname reqd
+ ((tidy', subst'), tyvar')
+ where
+ subst' = extendVarEnv subst tyvar tyvar'
+ tyvar' = setTyVarName tyvar name'
+ name' = mkLocalName (getUnique name) occ' noSrcLoc
+ -- Note: make a *user* tyvar, so it printes nicely
+ -- Could extract src loc, but no need.
where
name = tyVarName tyvar
-tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
-tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
-
tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
-- Add the free tyvars to the env in tidy form,
-- so that we can tidy the type they are free in
-tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
- where
- add env tv = fst (tidyTyVar env tv)
+tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
+
+tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
+tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
+
+tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+-- Treat a new tyvar as a binder, and give it a fresh tidy name
+tidyOpenTyVar env@(tidy_env, subst) tyvar
+ = case lookupVarEnv subst tyvar of
+ Just tyvar' -> (env, tyvar') -- Already substituted
+ Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder
tidyType :: TidyEnv -> Type -> Type
tidyType env@(tidy_env, subst) ty
Just tv' -> TyVarTy tv'
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
- go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
+ go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
go (SourceTy sty) = SourceTy (tidySourceType env sty)
- go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
- go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
- go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
+ go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
+ go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
+ go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty)
where
- (envp, tvp) = tidyTyVar env tv
- go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
+ (envp, tvp) = tidyTyVarBndr env tv
+ go (UsageTy u ty) = (UsageTy $! (go u)) $! (go ty)
- go_note (SynNote ty) = SynNote SAPPLY (go ty)
+ go_note (SynNote ty) = SynNote $! (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
tidyTypes env tys = map (tidyType env) tys
other -> False
\end{code}
+@isStrictType@ computes whether an argument (or let RHS) should
+be computed strictly or lazily, based only on its type.
+Works just like isUnLiftedType, except that it has a special case
+for dictionaries. Since it takes account of ClassP, you might think
+this function should be in TcType, but isStrictType is used by DataCon,
+which is below TcType in the hierarchy, so it's convenient to put it here.
+
+\begin{code}
+isStrictType (ForAllTy tv ty) = isStrictType ty
+isStrictType (NoteTy _ ty) = isStrictType ty
+isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
+isStrictType (UsageTy _ ty) = isStrictType ty
+isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
+ -- We may be strict in dictionary types, but only if it
+ -- has more than one component.
+ -- [Being strict in a single-component dictionary risks
+ -- poking the dictionary component, which is wrong.]
+isStrictType other = False
+\end{code}
+
+\begin{code}
+isPrimitiveType :: Type -> Bool
+-- Returns types that are opaque to Haskell.
+-- Most of these are unlifted, but now that we interact with .NET, we
+-- may have primtive (foreign-imported) types that are lifted
+isPrimitiveType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ isPrimTyCon tc
+ other -> False
+\end{code}
+
%************************************************************************
%* *
Just tv1a -> tv1a == tv2
Nothing -> tv1 == tv2
eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
- | tv1 == tv2 = eq_ty env t1 t2
+ | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2
| otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
projects / ghc-hetmet.git / blobdiff