+check_mono_type :: Rank -> Type -> TcM () -- No foralls anywhere
+ -- No unlifted types of any kind
+check_mono_type rank ty
+ = do { check_type rank UT_NotOk ty
+ ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
+
+check_type :: Rank -> UbxTupFlag -> Type -> TcM ()
+-- The args say what the *type context* requires, independent
+-- of *flag* settings. You test the flag settings at usage sites.
+--
+-- Rank is allowed rank for function args
+-- Rank 0 means no for-alls anywhere
+
+check_type rank ubx_tup ty
+ | not (null tvs && null theta)
+ = do { checkTc (nonZeroRank rank) (forAllTyErr rank ty)
+ -- Reject e.g. (Maybe (?x::Int => Int)),
+ -- with a decent error message
+ ; check_valid_theta SigmaCtxt theta
+ ; check_type rank ubx_tup tau -- Allow foralls to right of arrow
+ ; checkAmbiguity tvs theta (tyVarsOfType tau) }
+ where
+ (tvs, theta, tau) = tcSplitSigmaTy ty
+
+-- Naked PredTys should, I think, have been rejected before now
+check_type _ _ ty@(PredTy {})
+ = failWithTc (text "Predicate" <+> ppr ty <+> text "used as a type")
+
+check_type _ _ (TyVarTy _) = return ()
+
+check_type rank _ (FunTy arg_ty res_ty)
+ = do { check_type (decRank rank) UT_NotOk arg_ty
+ ; check_type rank UT_Ok res_ty }
+
+check_type rank _ (AppTy ty1 ty2)
+ = do { check_arg_type rank ty1
+ ; check_arg_type rank ty2 }
+
+check_type rank ubx_tup ty@(TyConApp tc tys)
+ | isSynTyCon tc
+ = do { -- Check that the synonym has enough args
+ -- This applies equally to open and closed synonyms
+ -- It's OK to have an *over-applied* type synonym
+ -- data Tree a b = ...
+ -- type Foo a = Tree [a]
+ -- f :: Foo a b -> ...
+ checkTc (tyConArity tc <= length tys) arity_msg
+
+ -- See Note [Liberal type synonyms]
+ ; liberal <- xoptM Opt_LiberalTypeSynonyms
+ ; if not liberal || isSynFamilyTyCon tc then
+ -- For H98 and synonym families, do check the type args
+ mapM_ (check_mono_type SynArgMonoType) tys
+
+ else -- In the liberal case (only for closed syns), expand then check
+ case tcView ty of
+ Just ty' -> check_type rank ubx_tup ty'
+ Nothing -> pprPanic "check_tau_type" (ppr ty)
+ }
+
+ | isUnboxedTupleTyCon tc
+ = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples
+ ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg
+
+ ; impred <- xoptM Opt_ImpredicativeTypes
+ ; let rank' = if impred then ArbitraryRank else TyConArgMonoType
+ -- c.f. check_arg_type
+ -- However, args are allowed to be unlifted, or
+ -- more unboxed tuples, so can't use check_arg_ty
+ ; mapM_ (check_type rank' UT_Ok) tys }
+
+ | otherwise
+ = mapM_ (check_arg_type rank) tys
+
+ where
+ ubx_tup_ok ub_tuples_allowed = case ubx_tup of
+ UT_Ok -> ub_tuples_allowed
+ _ -> False
+
+ n_args = length tys
+ tc_arity = tyConArity tc
+
+ arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args
+ ubx_tup_msg = ubxArgTyErr ty
+
+check_type _ _ ty = pprPanic "check_type" (ppr ty)