import UniqSupply
import SrcLoc
import Outputable
+import FastString
import Control.Monad ( when, unless )
import Data.List ( (\\) )
| isSynTyCon tc = go_syn tc tys
| otherwise = do { tys' <- mapM go tys
; return $ occurs (TyConApp tc) tys' }
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
go (PredTy p) = do { p' <- go_pred p
; return $ occurs1 PredTy p' }
go (FunTy arg res) = do { arg' <- go arg
| otherwise = return False
writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
-#ifndef DEBUG
-writeMetaTyVar tyvar ty = writeMutVar (metaTvRef tyvar) (Indirect ty)
-#else
+writeMetaTyVar tyvar ty
+ | not debugIsOn = writeMutVar (metaTvRef tyvar) (Indirect ty)
writeMetaTyVar tyvar ty
| not (isMetaTyVar tyvar)
= pprTrace "writeMetaTyVar" (ppr tyvar) $
return ()
-
| otherwise
= ASSERT( isMetaTyVar tyvar )
-- TOM: It should also work for coercions
where
k1 = tyVarKind tyvar
k2 = typeKind ty
-#endif
\end{code}
zonkType unbound_var_fn ty
= go ty
where
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
-
go (TyConApp tc tys) = do tys' <- mapM go tys
return (TyConApp tc tys')
= do { check_arg_type rank ty1
; check_arg_type rank ty2 }
-check_type rank ubx_tup (NoteTy other_note ty)
- = check_type rank ubx_tup ty
-
check_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
= do { -- Check that the synonym has enough args
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
----------------------------------------
-forAllTyErr ty = ptext SLIT("Illegal polymorphic or qualified type:") <+> ppr ty
-unliftedArgErr ty = ptext SLIT("Illegal unlifted type:") <+> ppr ty
-ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty
-kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
+forAllTyErr ty = sep [ptext SLIT("Illegal polymorphic or qualified type:"), ppr ty]
+unliftedArgErr ty = sep [ptext SLIT("Illegal unlifted type:"), ppr ty]
+ubxArgTyErr ty = sep [ptext SLIT("Illegal unboxed tuple type as function argument:"), ppr ty]
+kindErr kind = sep [ptext SLIT("Expecting an ordinary type, but found a type of kind"), ppr kind]
\end{code}
Note [Liberal type synonyms]
text "where T is not a synonym." $$
text "Use -XTypeSynonymInstances if you want to disable this.")
- head_type_args_tyvars_msg = parens (
- text "All instance types must be of the form (T a1 ... an)" $$
- text "where a1 ... an are distinct type *variables*" $$
- text "Use -XFlexibleInstances if you want to disable this.")
+ head_type_args_tyvars_msg = parens (vcat [
+ text "All instance types must be of the form (T a1 ... an)",
+ text "where a1 ... an are type *variables*,",
+ text "and each type variable appears at most once in the instance head.",
+ text "Use -XFlexibleInstances if you want to disable this."])
head_one_type_msg = parens (
text "Only one type can be given in an instance head." $$
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvType (TyVarTy tv) = [tv]
fvType (TyConApp _ tys) = fvTypes tys
-fvType (NoteTy _ ty) = fvType ty
fvType (PredTy pred) = fvPred pred
fvType (FunTy arg res) = fvType arg ++ fvType res
fvType (AppTy fun arg) = fvType fun ++ fvType arg
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
sizeType (TyVarTy _) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
-sizeType (NoteTy _ ty) = sizeType ty
sizeType (PredTy pred) = sizePred pred
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg