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 SrcLoc ( noSrcLoc )
import PrimRep ( PrimRep(..) )
import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList )
+import Util ( mapAccumL, seqList, lengthIs )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
| isNewTyCon tycon, -- A saturated newtype application;
not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
- length tys == tyConArity tycon -- use the SourceType form
+ tys `lengthIs` tyConArity tycon -- use the SourceType form
= SourceTy (NType tycon tys)
| otherwise
~~~~~
\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
+ = case splitAt arity tys of { (as,bs) -> foldl AppTy (mk_syn as) bs }
+ | 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
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 (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc
= repType (newTypeRep tc tys)
repType ty = ty
splitNewType_maybe ty
= case splitTyConApp_maybe ty of
- Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
+ Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc )
-- The assert should hold because repType should
-- only be applied to *types* (of kind *)
Just (newTypeRep tc 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
-- Should only be applied to *types*; hence the assert
isAlgType :: Type -> Bool
isAlgType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
isAlgTyCon tc
other -> False
\end{code}
-- 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 )
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` 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