%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section{Monadic type operations}
-This module contains monadic operations over types that contain mutable type variables
+Monadic type operations
+
+This module contains monadic operations over types that contain
+mutable type variables
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcMType (
TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars,
lookupTcTyVar, LookupTyVarResult(..),
- newMetaTyVar, readMetaTyVar, writeMetaTyVar,
+
+ newMetaTyVar, readMetaTyVar, writeMetaTyVar, isFilledMetaTyVar,
--------------------------------
-- Boxy type variables
newBoxyTyVar, newBoxyTyVars, newBoxyTyVarTys, readFilledBox,
--------------------------------
+ -- Creating new coercion variables
+ newCoVars, newMetaCoVar,
+
+ --------------------------------
-- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
- tcInstSigTyVars, zonkSigTyVar,
+ tcInstSigTyVars,
tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
- tcSkolSigType, tcSkolSigTyVars,
+ tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
--------------------------------
-- Checking type validity
- Rank, UserTypeCtxt(..), checkValidType,
+ Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
SourceTyCtxt(..), checkValidTheta, checkFreeness,
- checkValidInstHead, checkValidInstance, checkAmbiguity,
- checkInstTermination,
- arityErr,
+ checkValidInstHead, checkValidInstance,
+ checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
+ checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt,
+ unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs,
--------------------------------
-- Zonking
zonkType, zonkTcPredType,
- zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkQuantifiedTyVar,
+ zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
+ zonkQuantifiedTyVar, zonkQuantifiedTyVars,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
- zonkTcKindToKind, zonkTcKind,
+ zonkTcKindToKind, zonkTcKind, zonkTopTyVar,
readKindVar, writeKindVar
-
) where
#include "HsVersions.h"
-
-- friends:
-import TypeRep ( Type(..), PredType(..), -- Friend; can see representation
- ThetaType
- )
-import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
- TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
- MetaDetails(..), SkolemInfo(..), BoxInfo(..),
- BoxyTyVar, BoxyType, UserTypeCtxt(..),
- isMetaTyVar, isSigTyVar, metaTvRef,
- tcCmpPred, isClassPred, tcGetTyVar,
- tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
- tcValidInstHeadTy, tcSplitForAllTys,
- tcIsTyVarTy, tcSplitSigmaTy,
- isUnLiftedType, isIPPred,
- typeKind, isSkolemTyVar,
- mkAppTy, mkTyVarTy, mkTyVarTys,
- tyVarsOfPred, getClassPredTys_maybe,
- tyVarsOfType, tyVarsOfTypes, tcView,
- pprPred, pprTheta, pprClassPred )
-import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar,
- isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
- liftedTypeKind, defaultKind
- )
-import Type ( TvSubst, zipTopTvSubst, substTy )
-import Class ( Class, classArity, className )
-import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
- tyConArity, tyConName )
-import Var ( TyVar, tyVarKind, tyVarName, isTcTyVar,
- mkTyVar, mkTcTyVar, tcTyVarDetails )
-
- -- Assertions
-#ifdef DEBUG
-import TcType ( isFlexi, isBoxyTyVar, isImmutableTyVar )
-import Kind ( isSubKind )
-#endif
+import TypeRep
+import TcType
+import Type
+import Coercion
+import Class
+import TyCon
+import Var
-- others:
import TcRnMonad -- TcType, amongst others
-import FunDeps ( grow, checkInstCoverage )
-import Name ( Name, setNameUnique, mkSysTvName )
+import FunDeps
+import Name
import VarSet
-import DynFlags ( dopt, DynFlag(..) )
-import Util ( nOfThem, isSingleton, notNull )
-import ListSetOps ( removeDups )
+import ErrUtils
+import DynFlags
+import Util
+import Maybes
+import ListSetOps
+import UniqSupply
+import SrcLoc
import Outputable
-import Control.Monad ( when )
+import Control.Monad ( when, unless )
import Data.List ( (\\) )
\end{code}
tcInstType :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables
-> TcType -- Type to instantiate
-> TcM ([TcTyVar], TcThetaType, TcType) -- Result
+ -- (type vars (excl coercion vars), preds (incl equalities), rho)
tcInstType inst_tyvars ty
= case tcSplitForAllTys ty of
([], rho) -> let -- There may be overloading despite no type variables;
%************************************************************************
%* *
+ Updating tau types
+%* *
+%************************************************************************
+
+Can't be in TcUnify, as we also need it in TcTyFuns.
+
+\begin{code}
+type SwapFlag = Bool
+ -- False <=> the two args are (actual, expected) respectively
+ -- True <=> the two args are (expected, actual) respectively
+
+checkUpdateMeta :: SwapFlag
+ -> TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
+-- Update tv1, which is flexi; occurs check is alrady done
+-- The 'check' version does a kind check too
+-- We do a sub-kind check here: we might unify (a b) with (c d)
+-- where b::*->* and d::*; this should fail
+
+checkUpdateMeta swapped tv1 ref1 ty2
+ = do { checkKinds swapped tv1 ty2
+ ; updateMeta tv1 ref1 ty2 }
+
+updateMeta :: TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
+updateMeta tv1 ref1 ty2
+ = ASSERT( isMetaTyVar tv1 )
+ ASSERT( isBoxyTyVar tv1 || isTauTy ty2 )
+ do { ASSERTM2( do { details <- readMetaTyVar tv1; return (isFlexi details) }, ppr tv1 )
+ ; traceTc (text "updateMeta" <+> ppr tv1 <+> text ":=" <+> ppr ty2)
+ ; writeMutVar ref1 (Indirect ty2)
+ }
+
+----------------
+checkKinds swapped tv1 ty2
+-- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
+-- ty2 has been zonked at this stage, which ensures that
+-- its kind has as much boxity information visible as possible.
+ | tk2 `isSubKind` tk1 = returnM ()
+
+ | otherwise
+ -- Either the kinds aren't compatible
+ -- (can happen if we unify (a b) with (c d))
+ -- or we are unifying a lifted type variable with an
+ -- unlifted type: e.g. (id 3#) is illegal
+ = addErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
+ unifyKindMisMatch k1 k2
+ where
+ (k1,k2) | swapped = (tk2,tk1)
+ | otherwise = (tk1,tk2)
+ tk1 = tyVarKind tv1
+ tk2 = typeKind ty2
+
+----------------
+checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
+-- (checkTauTvUpdate tv ty)
+-- We are about to update the TauTv tv with ty.
+-- Check (a) that tv doesn't occur in ty (occurs check)
+-- (b) that ty is a monotype
+-- Furthermore, in the interest of (b), if you find an
+-- empty box (BoxTv that is Flexi), fill it in with a TauTv
+--
+-- We have three possible outcomes:
+-- (1) Return the (non-boxy) type to update the type variable with,
+-- [we know the update is ok!]
+-- (2) return Nothing, or
+-- [we cannot tell whether the update is ok right now]
+-- (3) fails.
+-- [the update is definitely invalid]
+-- We return Nothing in case the tv occurs in ty *under* a type family
+-- application. In this case, we must not update tv (to avoid a cyclic type
+-- term), but we also cannot fail claiming an infinite type. Given
+-- type family F a
+-- type instance F Int = Int
+-- consider
+-- a ~ F a
+-- This is perfectly reasonable, if we later get a ~ Int.
+
+checkTauTvUpdate orig_tv orig_ty
+ = do { result <- go orig_ty
+ ; case result of
+ Right ty -> return $ Just ty
+ Left True -> return $ Nothing
+ Left False -> occurCheckErr (mkTyVarTy orig_tv) orig_ty
+ }
+ where
+ go :: TcType -> TcM (Either Bool TcType)
+ -- go returns
+ -- Right ty if everything is fine
+ -- Left True if orig_tv occurs in orig_ty, but under a type family app
+ -- Left False if orig_tv occurs in orig_ty (with no type family app)
+ -- It fails if it encounters a forall type, except as an argument for a
+ -- closed type synonym that expands to a tau type.
+ go (TyConApp tc tys)
+ | isSynTyCon tc = go_syn tc tys
+ | otherwise = do { tys' <- mappM 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
+ ; res' <- go res
+ ; return $ occurs2 FunTy arg' res' }
+ go (AppTy fun arg) = do { fun' <- go fun
+ ; arg' <- go arg
+ ; return $ occurs2 mkAppTy fun' arg' }
+ -- NB the mkAppTy; we might have instantiated a
+ -- type variable to a type constructor, so we need
+ -- to pull the TyConApp to the top.
+ go (ForAllTy tv ty) = notMonoType orig_ty -- (b)
+
+ go (TyVarTy tv)
+ | orig_tv == tv = return $ Left False -- (a)
+ | isTcTyVar tv = go_tyvar tv (tcTyVarDetails tv)
+ | otherwise = return $ Right (TyVarTy tv)
+ -- Ordinary (non Tc) tyvars
+ -- occur inside quantified types
+
+ go_pred (ClassP c tys) = do { tys' <- mapM go tys
+ ; return $ occurs (ClassP c) tys' }
+ go_pred (IParam n ty) = do { ty' <- go ty
+ ; return $ occurs1 (IParam n) ty' }
+ go_pred (EqPred t1 t2) = do { t1' <- go t1
+ ; t2' <- go t2
+ ; return $ occurs2 EqPred t1' t2' }
+
+ go_tyvar tv (SkolemTv _) = return $ Right (TyVarTy tv)
+ go_tyvar tv (MetaTv box ref)
+ = do { cts <- readMutVar ref
+ ; case cts of
+ Indirect ty -> go ty
+ Flexi -> case box of
+ BoxTv -> do { ty <- fillBoxWithTau tv ref
+ ; return $ Right ty }
+ other -> return $ Right (TyVarTy tv)
+ }
+
+ -- go_syn is called for synonyms only
+ -- See Note [Type synonyms and the occur check]
+ go_syn tc tys
+ | not (isTauTyCon tc)
+ = notMonoType orig_ty -- (b) again
+ | otherwise
+ = do { (msgs, mb_tys') <- tryTc (mapM go tys)
+ ; case mb_tys' of
+
+ -- we had a type error => forall in type parameters
+ Nothing
+ | isOpenTyCon tc -> notMonoArgs (TyConApp tc tys)
+ -- Synonym families must have monotype args
+ | otherwise -> go (expectJust "checkTauTvUpdate(1)"
+ (tcView (TyConApp tc tys)))
+ -- Try again, expanding the synonym
+
+ -- no type error, but need to test whether occurs check happend
+ Just tys' ->
+ case occurs id tys' of
+ Left _
+ | isOpenTyCon tc -> return $ Left True
+ -- Variable occured under type family application
+ | otherwise -> go (expectJust "checkTauTvUpdate(2)"
+ (tcView (TyConApp tc tys)))
+ -- Try again, expanding the synonym
+ Right raw_tys' -> return $ Right (TyConApp tc raw_tys')
+ -- Retain the synonym (the common case)
+ }
+
+ -- Left results (= occurrence of orig_ty) dominate and
+ -- (Left False) (= fatal occurrence) dominates over (Left True)
+ occurs :: ([a] -> b) -> [Either Bool a] -> Either Bool b
+ occurs c = either Left (Right . c) . foldr combine (Right [])
+ where
+ combine (Left famInst1) (Left famInst2) = Left (famInst1 && famInst2)
+ combine (Right _ ) (Left famInst) = Left famInst
+ combine (Left famInst) (Right _) = Left famInst
+ combine (Right arg) (Right args) = Right (arg:args)
+
+ occurs1 c x = occurs (\[x'] -> c x') [x]
+ occurs2 c x y = occurs (\[x', y'] -> c x' y') [x, y]
+
+fillBoxWithTau :: BoxyTyVar -> IORef MetaDetails -> TcM TcType
+-- (fillBoxWithTau tv ref) fills ref with a freshly allocated
+-- tau-type meta-variable, whose print-name is the same as tv
+-- Choosing the same name is good: when we instantiate a function
+-- we allocate boxy tyvars with the same print-name as the quantified
+-- tyvar; and then we often fill the box with a tau-tyvar, and again
+-- we want to choose the same name.
+fillBoxWithTau tv ref
+ = do { tv' <- tcInstTyVar tv -- Do not gratuitously forget
+ ; let tau = mkTyVarTy tv' -- name of the type variable
+ ; writeMutVar ref (Indirect tau)
+ ; return tau }
+\end{code}
+
+Note [Type synonyms and the occur check]
+~~~~~~~~~~~~~~~~~~~~
+Basically we want to update tv1 := ps_ty2
+because ps_ty2 has type-synonym info, which improves later error messages
+
+But consider
+ type A a = ()
+
+ f :: (A a -> a -> ()) -> ()
+ f = \ _ -> ()
+
+ x :: ()
+ x = f (\ x p -> p x)
+
+In the application (p x), we try to match "t" with "A t". If we go
+ahead and bind t to A t (= ps_ty2), we'll lead the type checker into
+an infinite loop later.
+But we should not reject the program, because A t = ().
+Rather, we should bind t to () (= non_var_ty2).
+
+--------------
+
+Error mesages in case of kind mismatch.
+
+\begin{code}
+unifyKindMisMatch ty1 ty2
+ = zonkTcKind ty1 `thenM` \ ty1' ->
+ zonkTcKind ty2 `thenM` \ ty2' ->
+ let
+ msg = hang (ptext SLIT("Couldn't match kind"))
+ 2 (sep [quotes (ppr ty1'),
+ ptext SLIT("against"),
+ quotes (ppr ty2')])
+ in
+ failWithTc msg
+
+unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred
+ -- tv1 and ty2 are zonked already
+ = returnM msg
+ where
+ msg = (env2, ptext SLIT("When matching the kinds of") <+>
+ sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual])
+
+ (pp_expected, pp_actual) | swapped = (pp2, pp1)
+ | otherwise = (pp1, pp2)
+ (env1, tv1') = tidyOpenTyVar tidy_env tv1
+ (env2, ty2') = tidyOpenType env1 ty2
+ pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1)
+ pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
+\end{code}
+
+Error message for failure due to an occurs check.
+
+\begin{code}
+occurCheckErr :: TcType -> TcType -> TcM a
+occurCheckErr ty containingTy
+ = do { env0 <- tcInitTidyEnv
+ ; ty' <- zonkTcType ty
+ ; containingTy' <- zonkTcType containingTy
+ ; let (env1, tidy_ty1) = tidyOpenType env0 ty'
+ (env2, tidy_ty2) = tidyOpenType env1 containingTy'
+ extra = sep [ppr tidy_ty1, char '=', ppr tidy_ty2]
+ ; failWithTcM (env2, hang msg 2 extra) }
+ where
+ msg = ptext SLIT("Occurs check: cannot construct the infinite type:")
+\end{code}
+
+%************************************************************************
+%* *
Kind variables
%* *
%************************************************************************
\begin{code}
+newCoVars :: [(TcType,TcType)] -> TcM [CoVar]
+newCoVars spec
+ = do { us <- newUniqueSupply
+ ; return [ mkCoVar (mkSysTvName uniq FSLIT("co"))
+ (mkCoKind ty1 ty2)
+ | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
+
+newMetaCoVar :: TcType -> TcType -> TcM TcTyVar
+newMetaCoVar ty1 ty2 = newMetaTyVar TauTv (mkCoKind ty1 ty2)
+
newKindVar :: TcM TcKind
newKindVar = do { uniq <- newUnique
- ; ref <- newMutVar Nothing
- ; return (KindVar (mkKindVar uniq ref)) }
+ ; ref <- newMutVar Flexi
+ ; return (mkTyVarTy (mkKindVar uniq ref)) }
newKindVars :: Int -> TcM [TcKind]
newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
| tv <- tyvars ]
-tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type with fresh skolem constants
-tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
-
-tcInstSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar
-tcInstSkolTyVar info tyvar
+tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar
+-- Instantiate the tyvar, using
+-- * the occ-name and kind of the supplied tyvar,
+-- * the unique from the monad,
+-- * the location either from the tyvar (mb_loc = Nothing)
+-- or from mb_loc (Just loc)
+tcInstSkolTyVar info mb_loc tyvar
= do { uniq <- newUnique
- ; let name = setNameUnique (tyVarName tyvar) uniq
- kind = tyVarKind tyvar
- ; return (mkSkolTyVar name kind info) }
+ ; let old_name = tyVarName tyvar
+ kind = tyVarKind tyvar
+ loc = mb_loc `orElse` getSrcSpan old_name
+ new_name = mkInternalName uniq (nameOccName old_name) loc
+ ; return (mkSkolTyVar new_name kind info) }
tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
-tcInstSkolTyVars info tyvars = mapM (tcInstSkolTyVar info) tyvars
+-- Get the location from the monad
+tcInstSkolTyVars info tyvars
+ = do { span <- getSrcSpanM
+ ; mapM (tcInstSkolTyVar info (Just span)) tyvars }
+
+tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type with fresh skolem constants
+-- Binding location comes from the monad
+tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
\end{code}
-- Make a new meta tyvar out of thin air
newMetaTyVar box_info kind
= do { uniq <- newUnique
- ; ref <- newMutVar Flexi ;
+ ; ref <- newMutVar Flexi
; let name = mkSysTvName uniq fs
fs = case box_info of
- BoxTv -> FSLIT("bx")
+ BoxTv -> FSLIT("t")
TauTv -> FSLIT("t")
SigTv _ -> FSLIT("a")
+ -- We give BoxTv and TauTv the same string, because
+ -- otherwise we get user-visible differences in error
+ -- messages, which are confusing. If you want to see
+ -- the box_info of each tyvar, use -dppr-debug
; return (mkTcTyVar name kind (MetaTv box_info ref)) }
instMetaTyVar :: BoxInfo -> TyVar -> TcM TcTyVar
-- come from an existing TyVar
instMetaTyVar box_info tyvar
= do { uniq <- newUnique
- ; ref <- newMutVar Flexi ;
+ ; ref <- newMutVar Flexi
; let name = setNameUnique (tyVarName tyvar) uniq
kind = tyVarKind tyvar
; return (mkTcTyVar name kind (MetaTv box_info ref)) }
readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
readMutVar (metaTvRef tyvar)
+isFilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a filled-in (Indirect) meta type variable
+isFilledMetaTyVar tv
+ | not (isTcTyVar tv) = return False
+ | MetaTv _ ref <- tcTyVarDetails tv
+ = do { details <- readMutVar ref
+ ; return (isIndirect details) }
+ | otherwise = return False
+
writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
#ifndef DEBUG
writeMetaTyVar tyvar ty = writeMutVar (metaTvRef tyvar) (Indirect ty)
| otherwise
= ASSERT( isMetaTyVar tyvar )
- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
+ -- TOM: It should also work for coercions
+ -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
; writeMutVar (metaTvRef tyvar) (Indirect ty) }
where
%************************************************************************
\begin{code}
-tcInstSigTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
--- Instantiate with meta SigTvs
-tcInstSigTyVars skol_info tyvars
+tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
+-- Instantiate with skolems or meta SigTvs; depending on use_skols
+-- Always take location info from the supplied tyvars
+tcInstSigTyVars use_skols skol_info tyvars
+ | use_skols
+ = mapM (tcInstSkolTyVar skol_info Nothing) tyvars
+
+ | otherwise
= mapM (instMetaTyVar (SigTv skol_info)) tyvars
zonkSigTyVar :: TcTyVar -> TcM TcTyVar
readFilledBox box_tv = ASSERT( isBoxyTyVar box_tv )
do { cts <- readMetaTyVar box_tv
; case cts of
- Flexi -> pprPanic "readFilledBox" (ppr box_tv)
+ Flexi -> pprPanic "readFilledBox" (ppr box_tv)
Indirect ty -> return ty }
tcInstBoxyTyVar :: TyVar -> TcM BoxyTyVar
lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
lookupTcTyVar tyvar
- = case details of
+ = ASSERT2( isTcTyVar tyvar, ppr tyvar )
+ case details of
SkolemTv _ -> return (DoneTv details)
MetaTv _ ref -> do { meta_details <- readMutVar ref
; case meta_details of
Indirect ty -> return (IndirectTv ty)
- Flexi -> return (DoneTv details) }
+ Flexi -> return (DoneTv details) }
where
details = tcTyVarDetails tyvar
returnM (tyVarsOfTypes tys)
zonkTcTyVar :: TcTyVar -> TcM TcType
-zonkTcTyVar tyvar = ASSERT( isTcTyVar tyvar )
+zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)
zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
\end{code}
zonkTcPredType (IParam n t)
= zonkTcType t `thenM` \ new_t ->
returnM (IParam n new_t)
+zonkTcPredType (EqPred t1 t2)
+ = zonkTcType t1 `thenM` \ new_t1 ->
+ zonkTcType t2 `thenM` \ new_t2 ->
+ returnM (EqPred new_t1 new_t2)
\end{code}
------------------- These ...ToType, ...ToKind versions
are used at the end of type checking
\begin{code}
-zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar
+zonkTopTyVar :: TcTyVar -> TcM TcTyVar
+-- zonkTopTyVar is used, at the top level, on any un-instantiated meta type variables
+-- to default the kind of ? and ?? etc to *. This is important to ensure that
+-- instance declarations match. For example consider
+-- instance Show (a->b)
+-- foo x = show (\_ -> True)
+-- Then we'll get a constraint (Show (p ->q)) where p has argTypeKind (printed ??),
+-- and that won't match the typeKind (*) in the instance decl.
+--
+-- Because we are at top level, no further constraints are going to affect these
+-- type variables, so it's time to do it by hand. However we aren't ready
+-- to default them fully to () or whatever, because the type-class defaulting
+-- rules have yet to run.
+
+zonkTopTyVar tv
+ | k `eqKind` default_k = return tv
+ | otherwise
+ = do { tv' <- newFlexiTyVar default_k
+ ; writeMetaTyVar tv (mkTyVarTy tv')
+ ; return tv' }
+ where
+ k = tyVarKind tv
+ default_k = defaultKind k
+
+zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
+zonkQuantifiedTyVars = mappM zonkQuantifiedTyVar
+
+zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
-- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it.
--- It might be a meta TyVar, in which case we freeze it into an ordinary TyVar.
--- When we do this, we also default the kind -- see notes with Kind.defaultKind
--- The meta tyvar is updated to point to the new regular TyVar. Now any
+--
+-- The quantified type variables often include meta type variables
+-- we want to freeze them into ordinary type variables, and
+-- default their kind (e.g. from OpenTypeKind to TypeKind)
+-- -- see notes with Kind.defaultKind
+-- The meta tyvar is updated to point to the new skolem TyVar. Now any
-- bound occurences of the original type variable will get zonked to
-- the immutable version.
--
-- We leave skolem TyVars alone; they are immutable.
zonkQuantifiedTyVar tv
- | isSkolemTyVar tv = return tv
+ | ASSERT( isTcTyVar tv )
+ isSkolemTyVar tv = return tv
-- It might be a skolem type variable,
-- for example from a user type signature
| otherwise -- It's a meta-type-variable
= do { details <- readMetaTyVar tv
- -- Create the new, frozen, regular type variable
+ -- Create the new, frozen, skolem type variable
+ -- We zonk to a skolem, not to a regular TcVar
+ -- See Note [Zonking to Skolem]
; let final_kind = defaultKind (tyVarKind tv)
- final_tv = mkTyVar (tyVarName tv) final_kind
+ final_tv = mkSkolTyVar (tyVarName tv) final_kind UnkSkol
-- Bind the meta tyvar to the new tyvar
; case details of
; return final_tv }
\end{code}
-[Silly Type Synonyms]
-
+Note [Silly Type Synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
type C u a = u -- Note 'a' unused
All very silly. I think its harmless to ignore the problem. We'll end up with
a /\a in the final result but all the occurrences of a will be zonked to ()
+Note [Zonking to Skolem]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We used to zonk quantified type variables to regular TyVars. However, this
+leads to problems. Consider this program from the regression test suite:
+
+ eval :: Int -> String -> String -> String
+ eval 0 root actual = evalRHS 0 root actual
+
+ evalRHS :: Int -> a
+ evalRHS 0 root actual = eval 0 root actual
+
+It leads to the deferral of an equality
+
+ (String -> String -> String) ~ a
+
+which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).
+In the meantime `a' is zonked and quantified to form `evalRHS's signature.
+This has the *side effect* of also zonking the `a' in the deferred equality
+(which at this point is being handed around wrapped in an implication
+constraint).
+
+Finally, the equality (with the zonked `a') will be handed back to the
+simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop.
+If we zonk `a' with a regular type variable, we will have this regular type
+variable now floating around in the simplifier, which in many places assumes to
+only see proper TcTyVars.
+
+We can avoid this problem by zonking with a skolem. The skolem is rigid
+(which we requirefor a quantified variable), but is still a TcTyVar that the
+simplifier knows how to deal with.
+
%************************************************************************
%* *
go ty `thenM` \ ty' ->
returnM (ForAllTy tyvar ty')
- go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' ->
- returnM (ClassP c tys')
- go_pred (IParam n ty) = go ty `thenM` \ ty' ->
- returnM (IParam n ty')
+ go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' ->
+ returnM (ClassP c tys')
+ go_pred (IParam n ty) = go ty `thenM` \ ty' ->
+ returnM (IParam n ty')
+ go_pred (EqPred ty1 ty2) = go ty1 `thenM` \ ty1' ->
+ go ty2 `thenM` \ ty2' ->
+ returnM (EqPred ty1' ty2')
zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
-> TcTyVar -> TcM TcType
%************************************************************************
\begin{code}
-readKindVar :: KindVar -> TcM (Maybe TcKind)
+readKindVar :: KindVar -> TcM (MetaDetails)
writeKindVar :: KindVar -> TcKind -> TcM ()
readKindVar kv = readMutVar (kindVarRef kv)
-writeKindVar kv val = writeMutVar (kindVarRef kv) (Just val)
+writeKindVar kv val = writeMutVar (kindVarRef kv) (Indirect val)
-------------
zonkTcKind :: TcKind -> TcM TcKind
-zonkTcKind (FunKind k1 k2) = do { k1' <- zonkTcKind k1
- ; k2' <- zonkTcKind k2
- ; returnM (FunKind k1' k2') }
-zonkTcKind k@(KindVar kv) = do { mb_kind <- readKindVar kv
- ; case mb_kind of
- Nothing -> returnM k
- Just k -> zonkTcKind k }
-zonkTcKind other_kind = returnM other_kind
+zonkTcKind k = zonkTcType k
-------------
zonkTcKindToKind :: TcKind -> TcM Kind
-zonkTcKindToKind (FunKind k1 k2) = do { k1' <- zonkTcKindToKind k1
- ; k2' <- zonkTcKindToKind k2
- ; returnM (FunKind k1' k2') }
-
-zonkTcKindToKind (KindVar kv) = do { mb_kind <- readKindVar kv
- ; case mb_kind of
- Nothing -> return liftedTypeKind
- Just k -> zonkTcKindToKind k }
-
-zonkTcKindToKind OpenTypeKind = returnM liftedTypeKind -- An "Open" kind defaults to *
-zonkTcKindToKind other_kind = returnM other_kind
+-- When zonking a TcKind to a kind, we need to instantiate kind variables,
+-- Haskell specifies that * is to be used, so we follow that.
+zonkTcKindToKind k = zonkType (\ _ -> return liftedTypeKind) k
\end{code}
%************************************************************************
-- Checks that the type is valid for the given context
checkValidType ctxt ty
= traceTc (text "checkValidType" <+> ppr ty) `thenM_`
- doptM Opt_GlasgowExts `thenM` \ gla_exts ->
+ doptM Opt_UnboxedTuples `thenM` \ unboxed ->
+ doptM Opt_Rank2Types `thenM` \ rank2 ->
+ doptM Opt_RankNTypes `thenM` \ rankn ->
+ doptM Opt_PolymorphicComponents `thenM` \ polycomp ->
let
- rank | gla_exts = Arbitrary
+ rank | rankn = Arbitrary
+ | rank2 = Rank 2
| otherwise
= case ctxt of -- Haskell 98
GenPatCtxt -> Rank 0
TySynCtxt _ -> Rank 0
ExprSigCtxt -> Rank 1
FunSigCtxt _ -> Rank 1
- ConArgCtxt _ -> Rank 1 -- We are given the type of the entire
- -- constructor, hence rank 1
+ ConArgCtxt _ -> if polycomp
+ then Rank 2
+ -- We are given the type of the entire
+ -- constructor, hence rank 1
+ else Rank 1
ForSigCtxt _ -> Rank 1
- RuleSigCtxt _ -> Rank 1
SpecInstCtxt -> Rank 1
actual_kind = typeKind ty
kind_ok = case ctxt of
TySynCtxt _ -> True -- Any kind will do
- ResSigCtxt -> isOpenTypeKind actual_kind
- ExprSigCtxt -> isOpenTypeKind actual_kind
+ ResSigCtxt -> isSubOpenTypeKind actual_kind
+ ExprSigCtxt -> isSubOpenTypeKind actual_kind
GenPatCtxt -> isLiftedTypeKind actual_kind
ForSigCtxt _ -> isLiftedTypeKind actual_kind
- other -> isArgTypeKind actual_kind
+ other -> isSubArgTypeKind actual_kind
- ubx_tup | not gla_exts = UT_NotOk
- | otherwise = case ctxt of
- TySynCtxt _ -> UT_Ok
- ExprSigCtxt -> UT_Ok
- other -> UT_NotOk
- -- Unboxed tuples ok in function results,
- -- but for type synonyms we allow them even at
- -- top level
+ ubx_tup = case ctxt of
+ TySynCtxt _ | unboxed -> UT_Ok
+ ExprSigCtxt | unboxed -> UT_Ok
+ _ -> UT_NotOk
in
-- Check that the thing has kind Type, and is lifted if necessary
checkTc kind_ok (kindErr actual_kind) `thenM_`
-- Check the internal validity of the type itself
- check_poly_type rank ubx_tup ty `thenM_`
+ check_type rank ubx_tup ty `thenM_`
traceTc (text "checkValidType done" <+> ppr ty)
+
+checkValidMonoType :: Type -> TcM ()
+checkValidMonoType ty = check_mono_type ty
\end{code}
decRank Arbitrary = Arbitrary
decRank (Rank n) = Rank (n-1)
+nonZeroRank :: Rank -> Bool
+nonZeroRank (Rank 0) = False
+nonZeroRank _ = True
+
----------------------------------------
data UbxTupFlag = UT_Ok | UT_NotOk
-- The "Ok" version means "ok if -fglasgow-exts is on"
----------------------------------------
-check_poly_type :: Rank -> UbxTupFlag -> Type -> TcM ()
-check_poly_type (Rank 0) ubx_tup ty
- = check_tau_type (Rank 0) ubx_tup ty
-
-check_poly_type rank ubx_tup ty
- | null tvs && null theta
- = check_tau_type rank ubx_tup ty
- | otherwise
- = do { check_valid_theta SigmaCtxt theta
- ; check_poly_type rank ubx_tup tau -- Allow foralls to right of arrow
+check_mono_type :: Type -> TcM () -- No foralls anywhere
+ -- No unlifted types of any kind
+check_mono_type ty
+ = do { check_type (Rank 0) 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 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
; checkFreeness tvs theta
; checkAmbiguity tvs theta (tyVarsOfType tau) }
where
(tvs, theta, tau) = tcSplitSigmaTy ty
-----------------------------------------
-check_arg_type :: Type -> TcM ()
--- The sort of type that can instantiate a type variable,
--- or be the argument of a type constructor.
--- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
--- Other unboxed types are very occasionally allowed as type
--- arguments depending on the kind of the type constructor
---
--- For example, we want to reject things like:
---
--- instance Ord a => Ord (forall s. T s a)
--- and
--- g :: T s (forall b.b)
---
--- NB: unboxed tuples can have polymorphic or unboxed args.
--- This happens in the workers for functions returning
--- product types with polymorphic components.
--- But not in user code.
--- Anyway, they are dealt with by a special case in check_tau_type
-
-check_arg_type ty
- = check_poly_type Arbitrary UT_NotOk ty `thenM_`
- checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty)
-
-----------------------------------------
-check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM ()
--- Rank is allowed rank for function args
--- No foralls otherwise
-
-check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty)
-check_tau_type rank ubx_tup ty@(FunTy (PredTy _) _) = failWithTc (forAllTyErr ty)
- -- Reject e.g. (Maybe (?x::Int => Int)), with a decent error message
-
-- Naked PredTys don't usually show up, but they can as a result of
-- {-# SPECIALISE instance Ord Char #-}
-- The Right Thing would be to fix the way that SPECIALISE instance pragmas
-- are handled, but the quick thing is just to permit PredTys here.
-check_tau_type rank ubx_tup (PredTy sty) = getDOpts `thenM` \ dflags ->
- check_source_ty dflags TypeCtxt sty
-
-check_tau_type rank ubx_tup (TyVarTy _) = returnM ()
-check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
- = check_poly_type (decRank rank) UT_NotOk arg_ty `thenM_`
- check_poly_type rank UT_Ok res_ty
-
-check_tau_type rank ubx_tup (AppTy ty1 ty2)
- = check_arg_type ty1 `thenM_` check_arg_type ty2
-
-check_tau_type rank ubx_tup (NoteTy other_note ty)
- = check_tau_type rank ubx_tup ty
-
-check_tau_type rank ubx_tup ty@(TyConApp tc tys)
- | isSynTyCon tc
- = do { -- It's OK to have an *over-applied* type synonym
+check_type rank ubx_tup (PredTy sty)
+ = do { dflags <- getDOpts
+ ; check_pred_ty dflags TypeCtxt sty }
+
+check_type rank ubx_tup (TyVarTy _) = returnM ()
+check_type rank ubx_tup ty@(FunTy arg_ty res_ty)
+ = do { check_type (decRank rank) UT_NotOk arg_ty
+ ; check_type rank UT_Ok res_ty }
+
+check_type rank ubx_tup (AppTy ty1 ty2)
+ = 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
+ -- 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 -> ...
- ; case tcView ty of
- Just ty' -> check_tau_type rank ubx_tup ty' -- Check expansion
- Nothing -> failWithTc arity_msg
-
- ; gla_exts <- doptM Opt_GlasgowExts
- ; if gla_exts then
- -- If -fglasgow-exts then don't check the type arguments
- -- This allows us to instantiate a synonym defn with a
- -- for-all type, or with a partially-applied type synonym.
- -- e.g. type T a b = a
- -- type S m = m ()
- -- f :: S (T Int)
- -- Here, T is partially applied, so it's illegal in H98.
- -- But if you expand S first, then T we get just
- -- f :: Int
- -- which is fine.
- returnM ()
- else
- -- For H98, do check the type args
- mappM_ check_arg_type tys
- }
+ checkTc (tyConArity tc <= length tys) arity_msg
+
+ -- See Note [Liberal type synonyms]
+ ; liberal <- doptM Opt_LiberalTypeSynonyms
+ ; if not liberal || isOpenSynTyCon tc then
+ -- For H98 and synonym families, do check the type args
+ mappM_ check_mono_type 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
- = doptM Opt_GlasgowExts `thenM` \ gla_exts ->
- checkTc (ubx_tup_ok gla_exts) ubx_tup_msg `thenM_`
- mappM_ (check_tau_type (Rank 0) UT_Ok) tys
- -- Args are allowed to be unlifted, or
+ = do { ub_tuples_allowed <- doptM Opt_UnboxedTuples
+ ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg
+
+ ; impred <- doptM Opt_ImpredicativeTypes
+ ; let rank' = if impred then rank else Rank 0
+ -- c.f. check_arg_type
+ -- However, args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
+ ; mappM_ (check_type rank' UT_Ok) tys }
| otherwise
- = mappM_ check_arg_type tys
+ = mappM_ (check_arg_type rank) tys
where
- ubx_tup_ok gla_exts = case ubx_tup of { UT_Ok -> gla_exts; other -> False }
+ ubx_tup_ok ub_tuples_allowed = case ubx_tup of { UT_Ok -> ub_tuples_allowed; other -> False }
n_args = length tys
tc_arity = tyConArity tc
ubx_tup_msg = ubxArgTyErr ty
----------------------------------------
+check_arg_type :: Rank -> Type -> TcM ()
+-- The sort of type that can instantiate a type variable,
+-- or be the argument of a type constructor.
+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
+-- Other unboxed types are very occasionally allowed as type
+-- arguments depending on the kind of the type constructor
+--
+-- For example, we want to reject things like:
+--
+-- instance Ord a => Ord (forall s. T s a)
+-- and
+-- g :: T s (forall b.b)
+--
+-- NB: unboxed tuples can have polymorphic or unboxed args.
+-- This happens in the workers for functions returning
+-- product types with polymorphic components.
+-- But not in user code.
+-- Anyway, they are dealt with by a special case in check_tau_type
+
+check_arg_type rank ty
+ = do { impred <- doptM Opt_ImpredicativeTypes
+ ; let rank' = if impred then rank else Rank 0 -- Monotype unless impredicative
+ ; check_type rank' UT_NotOk ty
+ ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
+
+----------------------------------------
forAllTyErr ty = ptext SLIT("Illegal polymorphic or qualified type:") <+> ppr ty
-unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> 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
\end{code}
+Note [Liberal type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
+doing validity checking. This allows us to instantiate a synonym defn
+with a for-all type, or with a partially-applied type synonym.
+ e.g. type T a b = a
+ type S m = m ()
+ f :: S (T Int)
+Here, T is partially applied, so it's illegal in H98. But if you
+expand S first, then T we get just
+ f :: Int
+which is fine.
+
+IMPORTANT: suppose T is a type synonym. Then we must do validity
+checking on an appliation (T ty1 ty2)
+
+ *either* before expansion (i.e. check ty1, ty2)
+ *or* after expansion (i.e. expand T ty1 ty2, and then check)
+ BUT NOT BOTH
+
+If we do both, we get exponential behaviour!!
+
+ data TIACons1 i r c = c i ::: r c
+ type TIACons2 t x = TIACons1 t (TIACons1 t x)
+ type TIACons3 t x = TIACons2 t (TIACons1 t x)
+ type TIACons4 t x = TIACons2 t (TIACons2 t x)
+ type TIACons7 t x = TIACons4 t (TIACons3 t x)
%************************************************************************
check_valid_theta ctxt theta
= getDOpts `thenM` \ dflags ->
warnTc (notNull dups) (dupPredWarn dups) `thenM_`
- mappM_ (check_source_ty dflags ctxt) theta
+ mappM_ (check_pred_ty dflags ctxt) theta
where
(_,dups) = removeDups tcCmpPred theta
-------------------------
-check_source_ty dflags ctxt pred@(ClassP cls tys)
- = -- Class predicates are valid in all contexts
- checkTc (arity == n_tys) arity_err `thenM_`
-
- -- Check the form of the argument types
- mappM_ check_arg_type tys `thenM_`
- checkTc (check_class_pred_tys dflags ctxt tys)
- (predTyVarErr pred $$ how_to_allow)
-
+check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM ()
+check_pred_ty dflags ctxt pred@(ClassP cls tys)
+ = do { -- Class predicates are valid in all contexts
+ ; checkTc (arity == n_tys) arity_err
+
+ -- Check the form of the argument types
+ ; mappM_ check_mono_type tys
+ ; checkTc (check_class_pred_tys dflags ctxt tys)
+ (predTyVarErr pred $$ how_to_allow)
+ }
where
class_name = className cls
arity = classArity cls
n_tys = length tys
arity_err = arityErr "Class" class_name arity n_tys
- how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this"))
+ how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this"))
-check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty
- -- Implicit parameters only allows in type
+check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
+ = do { -- Equational constraints are valid in all contexts if type
+ -- families are permitted
+ ; checkTc (dopt Opt_TypeFamilies dflags) (eqPredTyErr pred)
+
+ -- Check the form of the argument types
+ ; check_mono_type ty1
+ ; check_mono_type ty2
+ }
+
+check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_mono_type ty
+ -- Implicit parameters only allowed in type
-- signatures; not in instance decls, superclasses etc
- -- The reason for not allowing implicit params in instances is a bit subtle
+ -- The reason for not allowing implicit params in instances is a bit
+ -- subtle.
-- If we allowed instance (?x::Int, Eq a) => Foo [a] where ...
-- then when we saw (e :: (?x::Int) => t) it would be unclear how to
-- discharge all the potential usas of the ?x in e. For example, a
-- instance decl would show up two uses of ?x.
-- Catch-all
-check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty)
+check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty)
-------------------------
+check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool
check_class_pred_tys dflags ctxt tys
= case ctxt of
TypeCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
- InstThetaCtxt -> gla_exts || undecidable_ok || all tcIsTyVarTy tys
+ InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
-- Further checks on head and theta in
-- checkInstTermination
- other -> gla_exts || all tyvar_head tys
+ other -> flexible_contexts || all tyvar_head tys
where
- gla_exts = dopt Opt_GlasgowExts dflags
- undecidable_ok = dopt Opt_AllowUndecidableInstances dflags
+ flexible_contexts = dopt Opt_FlexibleContexts dflags
+ undecidable_ok = dopt Opt_UndecidableInstances dflags
-------------------------
tyvar_head ty -- Haskell 98 allows predicates of form
don't need to check for ambiguity either, because the test can't fail
(see is_ambig).
+
\begin{code}
checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
checkAmbiguity forall_tyvars theta tau_tyvars
complain pred = addErrTc (ambigErr pred)
extended_tau_vars = grow theta tau_tyvars
- -- Only a *class* predicate can give rise to ambiguity
- -- An *implicit parameter* cannot. For example:
- -- foo :: (?x :: [a]) => Int
- -- foo = length ?x
- -- is fine. The call site will suppply a particular 'x'
+ -- See Note [Implicit parameters and ambiguity] in TcSimplify
is_ambig pred = isClassPred pred &&
any ambig_var (varSetElems (tyVarsOfPred pred))
\begin{code}
checkFreeness forall_tyvars theta
- = mappM_ complain (filter is_free theta)
+ = do { flexible_contexts <- doptM Opt_FlexibleContexts
+ ; unless flexible_contexts $ mappM_ complain (filter is_free theta) }
where
is_free pred = not (isIPPred pred)
&& not (any bound_var (varSetElems (tyVarsOfPred pred)))
complain pred = addErrTc (freeErr pred)
freeErr pred
- = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
- ptext SLIT("are already in scope"),
- nest 4 (ptext SLIT("(at least one must be universally quantified here)"))
- ]
+ = sep [ ptext SLIT("All of the type variables in the constraint") <+>
+ quotes (pprPred pred)
+ , ptext SLIT("are already in scope") <+>
+ ptext SLIT("(at least one must be universally quantified here)")
+ , nest 4 $
+ ptext SLIT("(Use -XFlexibleContexts to lift this restriction)")
+ ]
\end{code}
\begin{code}
= vcat [ptext SLIT("In the context:") <+> pprTheta theta,
ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
-badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
+badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
+eqPredTyErr sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty
+ $$
+ parens (ptext SLIT("Use -XTypeFamilies to permit this"))
predTyVarErr pred = sep [ptext SLIT("Non type-variable argument"),
nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
n_arguments | n == 0 = ptext SLIT("no arguments")
| n == 1 = ptext SLIT("1 argument")
| True = hsep [int n, ptext SLIT("arguments")]
+
+-----------------
+notMonoType ty
+ = do { ty' <- zonkTcType ty
+ ; env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty'
+ msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
+ ; failWithTcM (env1, msg) }
+
+notMonoArgs ty
+ = do { ty' <- zonkTcType ty
+ ; env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty'
+ msg = ptext SLIT("Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty)
+ ; failWithTcM (env1, msg) }
\end{code}
Just (clas,tys) ->
getDOpts `thenM` \ dflags ->
- mappM_ check_arg_type tys `thenM_`
+ mappM_ check_mono_type tys `thenM_`
check_inst_head dflags clas tys `thenM_`
returnM (clas, tys)
}}
check_inst_head dflags clas tys
-- If GlasgowExts then check at least one isn't a type variable
- | dopt Opt_GlasgowExts dflags
- = mapM_ check_one tys
-
- -- WITH HASKELL 98, MUST HAVE C (T a b c)
- | otherwise
- = checkTc (isSingleton tys && tcValidInstHeadTy first_ty)
- (instTypeErr (pprClassPred clas tys) head_shape_msg)
-
- where
- (first_ty : _) = tys
-
- head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$
- text "where T is not a synonym, and a,b,c are distinct type variables")
-
+ = do checkTc (dopt Opt_TypeSynonymInstances dflags ||
+ all tcInstHeadTyNotSynonym tys)
+ (instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
+ checkTc (dopt Opt_FlexibleInstances dflags ||
+ all tcInstHeadTyAppAllTyVars tys)
+ (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
+ checkTc (dopt Opt_MultiParamTypeClasses dflags ||
+ isSingleton tys)
+ (instTypeErr (pprClassPred clas tys) head_one_type_msg)
+ mapM_ check_mono_type tys
-- For now, I only allow tau-types (not polytypes) in
-- the head of an instance decl.
-- E.g. instance C (forall a. a->a) is rejected
-- One could imagine generalising that, but I'm not sure
-- what all the consequences might be
- check_one ty = do { check_tau_type (Rank 0) UT_NotOk ty
- ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
+
+ where
+ head_type_synonym_msg = parens (
+ text "All instance types must be of the form (T t1 ... tn)" $$
+ 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_one_type_msg = parens (
+ text "Only one type can be given in an instance head." $$
+ text "Use -XMultiParamTypeClasses if you want to allow more.")
instTypeErr pp_ty msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty,
\begin{code}
checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
checkValidInstance tyvars theta clas inst_tys
- = do { gla_exts <- doptM Opt_GlasgowExts
- ; undecidable_ok <- doptM Opt_AllowUndecidableInstances
+ = do { undecidable_ok <- doptM Opt_UndecidableInstances
; checkValidTheta InstThetaCtxt theta
; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
-- Check that instance inference will terminate (if we care)
- -- For Haskell 98, checkValidTheta has already done that
- ; when (gla_exts && not undecidable_ok) $
- checkInstTermination theta inst_tys
+ -- For Haskell 98 this will already have been done by checkValidTheta,
+ -- but as we may be using other extensions we need to check.
+ ; unless undecidable_ok $
+ mapM_ addErrTc (checkInstTermination inst_tys theta)
-- The Coverage Condition
; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
(instTypeErr (pprClassPred clas inst_tys) msg)
}
where
- msg = parens (ptext SLIT("the Coverage Condition fails for one of the functional dependencies"))
+ msg = parens (vcat [ptext SLIT("the Coverage Condition fails for one of the functional dependencies;"),
+ undecidableMsg])
\end{code}
-Termination test: each assertion in the context satisfies
+Termination test: the so-called "Paterson conditions" (see Section 5 of
+"Understanding functionsl dependencies via Constraint Handling Rules,
+JFP Jan 2007).
+
+We check that each assertion in the context satisfies:
(1) no variable has more occurrences in the assertion than in the head, and
(2) the assertion has fewer constructors and variables (taken together
and counting repetitions) than the head.
\begin{code}
-checkInstTermination :: ThetaType -> [TcType] -> TcM ()
-checkInstTermination theta tys
- = do { mappM_ (check_nomore (fvTypes tys)) theta
- ; mappM_ (check_smaller (sizeTypes tys)) theta }
-
-check_nomore :: [TyVar] -> PredType -> TcM ()
-check_nomore fvs pred
- = checkTc (null (fvPred pred \\ fvs))
- (predUndecErr pred nomoreMsg $$ parens undecidableMsg)
-
-check_smaller :: Int -> PredType -> TcM ()
-check_smaller n pred
- = checkTc (sizePred pred < n)
- (predUndecErr pred smallerMsg $$ parens undecidableMsg)
+checkInstTermination :: [TcType] -> ThetaType -> [Message]
+checkInstTermination tys theta
+ = mapCatMaybes check theta
+ where
+ fvs = fvTypes tys
+ size = sizeTypes tys
+ check pred
+ | not (null (fvPred pred \\ fvs))
+ = Just (predUndecErr pred nomoreMsg $$ parens undecidableMsg)
+ | sizePred pred >= size
+ = Just (predUndecErr pred smallerMsg $$ parens undecidableMsg)
+ | otherwise
+ = Nothing
predUndecErr pred msg = sep [msg,
nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
nomoreMsg = ptext SLIT("Variable occurs more often in a constraint than in the instance head")
smallerMsg = ptext SLIT("Constraint is no smaller than the instance head")
undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this")
+\end{code}
+
+%************************************************************************
+%* *
+ Checking the context of a derived instance declaration
+%* *
+%************************************************************************
+
+Note [Exotic derived instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a 'derived' instance declaration, we *infer* the context. It's a
+bit unclear what rules we should apply for this; the Haskell report is
+silent. Obviously, constraints like (Eq a) are fine, but what about
+ data T f a = MkT (f a) deriving( Eq )
+where we'd get an Eq (f a) constraint. That's probably fine too.
+
+One could go further: consider
+ data T a b c = MkT (Foo a b c) deriving( Eq )
+ instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
+
+Notice that this instance (just) satisfies the Paterson termination
+conditions. Then we *could* derive an instance decl like this:
+
+ instance (C Int a, Eq b, Eq c) => Eq (T a b c)
+
+even though there is no instance for (C Int a), because there just
+*might* be an instance for, say, (C Int Bool) at a site where we
+need the equality instance for T's.
+
+However, this seems pretty exotic, and it's quite tricky to allow
+this, and yet give sensible error messages in the (much more common)
+case where we really want that instance decl for C.
+
+So for now we simply require that the derived instance context
+should have only type-variable constraints.
+
+Here is another example:
+ data Fix f = In (f (Fix f)) deriving( Eq )
+Here, if we are prepared to allow -fallow-undecidable-instances we
+could derive the instance
+ instance Eq (f (Fix f)) => Eq (Fix f)
+but this is so delicate that I don't think it should happen inside
+'deriving'. If you want this, write it yourself!
+
+NB: if you want to lift this condition, make sure you still meet the
+termination conditions! If not, the deriving mechanism generates
+larger and larger constraints. Example:
+ data Succ a = S a
+ data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
+
+Note the lack of a Show instance for Succ. First we'll generate
+ instance (Show (Succ a), Show a) => Show (Seq a)
+and then
+ instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
+and so on. Instead we want to complain of no instance for (Show (Succ a)).
+
+The bottom line
+~~~~~~~~~~~~~~~
+Allow constraints which consist only of type variables, with no repeats.
+
+\begin{code}
+validDerivPred :: PredType -> Bool
+validDerivPred (ClassP cls tys) = hasNoDups fvs && sizeTypes tys == length fvs
+ where fvs = fvTypes tys
+validDerivPred otehr = False
+\end{code}
+
+%************************************************************************
+%* *
+ Checking type instance well-formedness and termination
+%* *
+%************************************************************************
+
+\begin{code}
+-- Check that a "type instance" is well-formed (which includes decidability
+-- unless -fallow-undecidable-instances is given).
+--
+checkValidTypeInst :: [Type] -> Type -> TcM ()
+checkValidTypeInst typats rhs
+ = do { -- left-hand side contains no type family applications
+ -- (vanilla synonyms are fine, though)
+ ; mappM_ checkTyFamFreeness typats
+
+ -- the right-hand side is a tau type
+ ; checkTc (isTauTy rhs) $
+ polyTyErr rhs
+
+ -- we have a decidable instance unless otherwise permitted
+ ; undecidable_ok <- doptM Opt_UndecidableInstances
+ ; unless undecidable_ok $
+ mapM_ addErrTc (checkFamInst typats (tyFamInsts rhs))
+ }
+
+-- Make sure that each type family instance is
+-- (1) strictly smaller than the lhs,
+-- (2) mentions no type variable more often than the lhs, and
+-- (3) does not contain any further type family instances.
+--
+checkFamInst :: [Type] -- lhs
+ -> [(TyCon, [Type])] -- type family instances
+ -> [Message]
+checkFamInst lhsTys famInsts
+ = mapCatMaybes check famInsts
+ where
+ size = sizeTypes lhsTys
+ fvs = fvTypes lhsTys
+ check (tc, tys)
+ | not (all isTyFamFree tys)
+ = Just (famInstUndecErr famInst nestedMsg $$ parens undecidableMsg)
+ | not (null (fvTypes tys \\ fvs))
+ = Just (famInstUndecErr famInst nomoreVarMsg $$ parens undecidableMsg)
+ | size <= sizeTypes tys
+ = Just (famInstUndecErr famInst smallerAppMsg $$ parens undecidableMsg)
+ | otherwise
+ = Nothing
+ where
+ famInst = TyConApp tc tys
+
+-- Ensure that no type family instances occur in a type.
+--
+checkTyFamFreeness :: Type -> TcM ()
+checkTyFamFreeness ty
+ = checkTc (isTyFamFree ty) $
+ tyFamInstInIndexErr ty
+
+-- Check that a type does not contain any type family applications.
+--
+isTyFamFree :: Type -> Bool
+isTyFamFree = null . tyFamInsts
+
+-- Error messages
+
+tyFamInstInIndexErr ty
+ = hang (ptext SLIT("Illegal type family application in type instance") <>
+ colon) 4 $
+ ppr ty
+
+polyTyErr ty
+ = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $
+ ppr ty
+
+famInstUndecErr ty msg
+ = sep [msg,
+ nest 2 (ptext SLIT("in the type family application:") <+>
+ pprType ty)]
+
+nestedMsg = ptext SLIT("Nested type family application")
+nomoreVarMsg = ptext SLIT("Variable occurs more often than in instance head")
+smallerAppMsg = ptext SLIT("Application is no smaller than the instance head")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Auxiliary functions}
+%* *
+%************************************************************************
+
+\begin{code}
-- Free variables of a type, retaining repetitions, and expanding synonyms
fvType :: Type -> [TyVar]
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvPred :: PredType -> [TyVar]
fvPred (ClassP _ tys') = fvTypes tys'
fvPred (IParam _ ty) = fvType ty
+fvPred (EqPred ty1 ty2) = fvType ty1 ++ fvType ty2
-- Size of a type: the number of variables and constructors
sizeType :: Type -> Int
sizePred :: PredType -> Int
sizePred (ClassP _ tys') = sizeTypes tys'
sizePred (IParam _ ty) = sizeType ty
+sizePred (EqPred ty1 ty2) = sizeType ty1 + sizeType ty2
\end{code}