module TcMType (
  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,

  --------------------------------
  -- Creating new mutable type variables
  newFlexiTyVar,
  newFlexiTyVarTy,		-- Kind -> TcM TcType
  newFlexiTyVarTys,		-- Int -> Kind -> TcM [TcType]
  newKindVar, newKindVars, 
  mkTcTyVarName,

  newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
  isFilledMetaTyVar, isFlexiMetaTyVar,

  --------------------------------
  -- Creating new evidence variables
  newEvVar, newCoVar, newEvVars,
  writeWantedCoVar, readWantedCoVar, 
  newIP, newDict, newSilentGiven, isSilentEvVar,

  newWantedEvVar, newWantedEvVars,
  newTcEvBinds, addTcEvBind,

  --------------------------------
  -- Instantiation
  tcInstTyVar, tcInstTyVars, tcInstSigTyVars,
  tcInstType, instMetaTyVar,
  tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType,
  tcSkolDFunType, tcSuperSkolTyVars,

  --------------------------------
  -- Checking type validity
  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
  SourceTyCtxt(..), checkValidTheta, 
  checkValidInstance,
  checkValidTypeInst, checkTyFamFreeness,
  arityErr, 
  growPredTyVars, growThetaTyVars, validDerivPred,

  --------------------------------
  -- Zonking
  zonkType, mkZonkTcTyVar, zonkTcPredType, 
  zonkTcTypeCarefully,
  skolemiseUnboundMetaTyVar,
  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
  zonkQuantifiedTyVar, zonkQuantifiedTyVars,
  zonkTcType, zonkTcTypes, zonkTcThetaType,
  zonkTcKindToKind, zonkTcKind, 
  zonkImplication, zonkEvVar, zonkWantedEvVar, zonkFlavoredEvVar,
  zonkWC, zonkWantedEvVars,
  zonkTcTypeAndSubst,
  tcGetGlobalTyVars, 


  readKindVar, writeKindVar
  ) where

#include "HsVersions.h"

-- friends:
import TypeRep
import TcType
import Type
import Coercion
import Class
import TyCon
import Var

-- others:
import HsSyn		-- HsType
import TcRnMonad        -- TcType, amongst others
import Id
import FunDeps
import Name
import VarSet
import ErrUtils
import DynFlags
import Util
import Maybes
import ListSetOps
import BasicTypes
import SrcLoc
import Outputable
import FastString
import Unique( Unique )
import Bag

import Control.Monad
import Data.List        ( (\\) )

newKindVar :: TcM TcKind
newKindVar = do	{ uniq <- newUnique
		; ref <- newMutVar Flexi
		; return (mkTyVarTy (mkKindVar uniq ref)) }

newKindVars :: Int -> TcM [TcKind]
newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())

newEvVars :: TcThetaType -> TcM [EvVar]
newEvVars theta = mapM newEvVar theta

newWantedEvVar :: TcPredType -> TcM EvVar 
newWantedEvVar (EqPred ty1 ty2) = newCoVar ty1 ty2
newWantedEvVar (ClassP cls tys) = newDict cls tys
newWantedEvVar (IParam ip ty)   = newIP ip ty

newWantedEvVars :: TcThetaType -> TcM [EvVar] 
newWantedEvVars theta = mapM newWantedEvVar theta 

--------------
newEvVar :: TcPredType -> TcM EvVar
-- Creates new *rigid* variables for predicates
newEvVar (EqPred ty1 ty2) = newCoVar ty1 ty2
newEvVar (ClassP cls tys) = newDict  cls tys
newEvVar (IParam ip ty)   = newIP    ip ty

newCoVar :: TcType -> TcType -> TcM CoVar
newCoVar ty1 ty2
  = do { name <- newName (mkTyVarOccFS (fsLit "co"))
       ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }

newIP :: IPName Name -> TcType -> TcM IpId
newIP ip ty
  = do 	{ name <- newName (getOccName (ipNameName ip))
        ; return (mkLocalId name (mkPredTy (IParam ip ty))) }

newDict :: Class -> [TcType] -> TcM DictId
newDict cls tys 
  = do { name <- newName (mkDictOcc (getOccName cls))
       ; return (mkLocalId name (mkPredTy (ClassP cls tys))) }

newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

-----------------
newSilentGiven :: PredType -> TcM EvVar
-- Make a dictionary for a "silent" given dictionary
-- Behaves just like any EvVar except that it responds True to isSilentDict
-- This is used only to suppress confusing error reports
newSilentGiven (ClassP cls tys)
  = do { uniq <- newUnique
       ; let name = mkSystemName uniq (mkDictOcc (getOccName cls))
       ; return (mkLocalId name (mkPredTy (ClassP cls tys))) }
newSilentGiven (EqPred ty1 ty2)
  = do { uniq <- newUnique
       ; let name = mkSystemName uniq (mkTyVarOccFS (fsLit "co"))
       ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
newSilentGiven pred@(IParam {})
  = pprPanic "newSilentDict" (ppr pred) -- Implicit parameters rejected earlier

isSilentEvVar :: EvVar -> Bool
isSilentEvVar v = isSystemName (Var.varName v)
  -- Notice that all *other* evidence variables get Internal Names

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;
				-- 	(?x :: Int) => Int -> Int
			   (theta, tau) = tcSplitPhiTy rho
			 in
			 return ([], theta, tau)

	(tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars

			    ; let  tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
				-- Either the tyvars are freshly made, by inst_tyvars,
                                -- or any nested foralls have different binders.
                                -- Either way, zipTopTvSubst is ok

			    ; let  (theta, tau) = tcSplitPhiTy (substTy tenv rho)
			    ; return (tyvars', theta, tau) }

tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type signature with skolem constants, but 
-- do *not* give them fresh names, because we want the name to
-- be in the type environment: it is lexically scoped.
tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty

tcSuperSkolTyVars :: [TyVar] -> [TcTyVar]
-- Make skolem constants, but do *not* give them new names, as above
-- Moreover, make them "super skolems"; see comments with superSkolemTv
tcSuperSkolTyVars tyvars
  = [ mkTcTyVar (tyVarName tv) (tyVarKind tv) superSkolemTv
    | tv <- tyvars ]

tcInstSkolTyVar :: Bool -> 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 (skol_info = SigSkol)
--                     or from the monad (otherwise)
tcInstSkolTyVar overlappable tyvar
  = do	{ uniq <- newUnique
        ; loc <-  getSrcSpanM
	; let new_name = mkInternalName uniq occ loc
        ; return (mkTcTyVar new_name kind (SkolemTv overlappable)) }
  where
    old_name = tyVarName tyvar
    occ      = nameOccName old_name
    kind     = tyVarKind tyvar

tcInstSkolTyVars :: [TyVar] -> TcM [TcTyVar]
tcInstSkolTyVars tyvars = mapM (tcInstSkolTyVar False) tyvars

tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
tcInstSuperSkolTyVars tyvars = mapM (tcInstSkolTyVar True) tyvars

tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type with fresh skolem constants
-- Binding location comes from the monad
tcInstSkolType ty = tcInstType tcInstSkolTyVars ty

tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
-- Make meta SigTv type variables for patten-bound scoped type varaibles
-- We use SigTvs for them, so that they can't unify with arbitrary types
tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv)
		-- ToDo: the "function binding site is bogus

newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newMetaTyVar meta_info kind
  = do	{ uniq <- newMetaUnique
 	; ref <- newMutVar Flexi
        ; let name = mkTcTyVarName uniq s
              s = case meta_info of
                        TauTv   -> fsLit "t"
                        TcsTv   -> fsLit "u"
                        SigTv _ -> fsLit "a"
	; return (mkTcTyVar name kind (MetaTv meta_info ref)) }

mkTcTyVarName :: Unique -> FastString -> Name
-- Make sure that fresh TcTyVar names finish with a digit
-- leaving the un-cluttered names free for user names
mkTcTyVarName uniq str = mkSysTvName uniq str

instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar
-- Make a new meta tyvar whose Name and Kind 
-- come from an existing TyVar
instMetaTyVar meta_info tyvar
  = do	{ uniq <- newMetaUnique
 	; ref <- newMutVar Flexi
        ; let name = mkSystemName uniq (getOccName tyvar)
	      kind = tyVarKind tyvar
	; return (mkTcTyVar name kind (MetaTv meta_info ref)) }

readMetaTyVar :: TyVar -> TcM MetaDetails
readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
		      readMutVar (metaTvRef tyvar)

readWantedCoVar :: CoVar -> TcM MetaDetails
readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar )
		        readMutVar (metaTvRef covar)

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

isFlexiMetaTyVar :: TyVar -> TcM Bool
-- True of a un-filled-in (Flexi) meta type variable
isFlexiMetaTyVar tv
  | not (isTcTyVar tv) = return False
  | MetaTv _ ref <- tcTyVarDetails tv
  = do 	{ details <- readMutVar ref
	; return (isFlexi details) }
  | otherwise = return False

--------------------
writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
-- Write into a currently-empty MetaTyVar

writeMetaTyVar tyvar ty
  | not debugIsOn 
  = writeMetaTyVarRef tyvar (metaTvRef tyvar) ty

-- Everything from here on only happens if DEBUG is on
  | not (isTcTyVar tyvar)
  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
    return ()

  | MetaTv _ ref <- tcTyVarDetails tyvar
  = writeMetaTyVarRef tyvar ref ty

  | otherwise
  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
    return ()

writeWantedCoVar :: CoVar -> Coercion -> TcM () 
writeWantedCoVar cv co = writeMetaTyVar cv co 

--------------------
writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
-- Here the tyvar is for error checking only; 
-- the ref cell must be for the same tyvar
writeMetaTyVarRef tyvar ref ty
  | not debugIsOn 
  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
       ; writeMutVar ref (Indirect ty) }

-- Everything from here on only happens if DEBUG is on
  | not (isPredTy tv_kind)   -- Don't check kinds for updates to coercion variables
  , not (ty_kind `isSubKind` tv_kind)
  = WARN( True, hang (text "Ill-kinded update to meta tyvar")
                   2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
    return ()

  | otherwise
  = do { meta_details <- readMutVar ref; 
       ; WARN( not (isFlexi meta_details), 
                hang (text "Double update of meta tyvar")
                   2 (ppr tyvar $$ ppr meta_details) )

         traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
       ; writeMutVar ref (Indirect ty) }
  where
    tv_kind = tyVarKind tyvar
    ty_kind = typeKind ty

newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar kind = newMetaTyVar TauTv kind

newFlexiTyVarTy  :: Kind -> TcM TcType
newFlexiTyVarTy kind = do
    tc_tyvar <- newFlexiTyVar kind
    return (TyVarTy tc_tyvar)

newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)

tcInstTyVar :: TyVar -> TcM TcTyVar
-- Instantiate with a META type variable
tcInstTyVar tyvar = instMetaTyVar TauTv tyvar

tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
-- Instantiate with META type variables
tcInstTyVars tyvars
  = do	{ tc_tvs <- mapM tcInstTyVar tyvars
	; let tys = mkTyVarTys tc_tvs
	; return (tc_tvs, tys, zipTopTvSubst tyvars tys) }
		-- Since the tyvars are freshly made,
		-- they cannot possibly be captured by
		-- any existing for-alls.  Hence zipTopTvSubst

zonkSigTyVar :: TcTyVar -> TcM TcTyVar
zonkSigTyVar sig_tv 
  | isSkolemTyVar sig_tv 
  = return sig_tv	-- Happens in the call in TcBinds.checkDistinctTyVars
  | otherwise
  = ASSERT( isSigTyVar sig_tv )
    do { ty <- zonkTcTyVar sig_tv
       ; return (tcGetTyVar "zonkSigTyVar" ty) }
	-- 'ty' is bound to be a type variable, because SigTvs
	-- can only be unified with type variables

tcGetGlobalTyVars :: TcM TcTyVarSet
tcGetGlobalTyVars
  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
       ; gbl_tvs  <- readMutVar gtv_var
       ; gbl_tvs' <- zonkTcTyVarsAndFV gbl_tvs
       ; writeMutVar gtv_var gbl_tvs'
       ; return gbl_tvs' }

zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars

zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet
zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars)

-----------------  Types
zonkTcTypeCarefully :: TcType -> TcM TcType
-- Do not zonk type variables free in the environment
zonkTcTypeCarefully ty
  = do { env_tvs <- tcGetGlobalTyVars
       ; zonkType (zonk_tv env_tvs) ty }
  where
    zonk_tv env_tvs tv
      | tv `elemVarSet` env_tvs 
      = return (TyVarTy tv)
      | otherwise
      = ASSERT( isTcTyVar tv )
    	case tcTyVarDetails tv of
          SkolemTv {}   -> return (TyVarTy tv)
          RuntimeUnk {} -> return (TyVarTy tv)
          FlatSkol ty   -> zonkType (zonk_tv env_tvs) ty
          MetaTv _ ref  -> do { cts <- readMutVar ref
                              ; case cts of
			           Flexi       -> return (TyVarTy tv)
			           Indirect ty -> zonkType (zonk_tv env_tvs) ty }

zonkTcType :: TcType -> TcM TcType
-- Simply look through all Flexis
zonkTcType ty = zonkType zonkTcTyVar ty

zonkTcTyVar :: TcTyVar -> TcM TcType
-- Simply look through all Flexis
zonkTcTyVar tv
  = ASSERT2( isTcTyVar tv, ppr tv )
    case tcTyVarDetails tv of
      SkolemTv {}   -> return (TyVarTy tv)
      RuntimeUnk {} -> return (TyVarTy tv)
      FlatSkol ty   -> zonkTcType ty
      MetaTv _ ref  -> do { cts <- readMutVar ref
                          ; case cts of
		               Flexi       -> return (TyVarTy tv)
			       Indirect ty -> zonkTcType ty }

zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType
-- Zonk, and simultaneously apply a non-necessarily-idempotent substitution
zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
  where
    zonk_tv tv 
      = case tcTyVarDetails tv of
          SkolemTv {}   -> return (TyVarTy tv)
          RuntimeUnk {} -> return (TyVarTy tv)
          FlatSkol ty   -> zonkType zonk_tv ty
          MetaTv _ ref  -> do { cts <- readMutVar ref
                              ; case cts of
			           Flexi       -> zonk_flexi tv
			           Indirect ty -> zonkType zonk_tv ty }
    zonk_flexi tv
      = case lookupTyVar subst tv of
          Just ty -> zonkType zonk_tv ty
          Nothing -> return (TyVarTy tv)

zonkTcTypes :: [TcType] -> TcM [TcType]
zonkTcTypes tys = mapM zonkTcType tys

zonkTcThetaType :: TcThetaType -> TcM TcThetaType
zonkTcThetaType theta = mapM zonkTcPredType theta

zonkTcPredType :: TcPredType -> TcM TcPredType
zonkTcPredType (ClassP c ts)  = ClassP c <$> zonkTcTypes ts
zonkTcPredType (IParam n t)   = IParam n <$> zonkTcType t
zonkTcPredType (EqPred t1 t2) = EqPred <$> zonkTcType t1 <*> zonkTcType t2

zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
zonkQuantifiedTyVars = mapM zonkQuantifiedTyVar

zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
-- 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
  = ASSERT2( isTcTyVar tv, ppr tv ) 
    case tcTyVarDetails tv of
      SkolemTv {} -> WARN( True, ppr tv )  -- Dec10: Can this really happen?
                     do { kind <- zonkTcType (tyVarKind tv)
                        ; return $ setTyVarKind tv kind }
	-- It might be a skolem type variable, 
	-- for example from a user type signature

      MetaTv _ _ref -> 
#ifdef DEBUG               
			-- [Sept 04] Check for non-empty.  
		 	-- See note [Silly Type Synonym]
                      (readMutVar _ref >>= \cts -> 
                       case cts of 
                             Flexi -> return ()
                             Indirect ty -> WARN( True, ppr tv $$ ppr ty )
                                            return ()) >>
#endif
                      skolemiseUnboundMetaTyVar tv vanillaSkolemTv
      _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk

skolemiseUnboundMetaTyVar :: TcTyVar -> TcTyVarDetails -> TcM TyVar
-- We have a Meta tyvar with a ref-cell inside it
-- Skolemise it, including giving it a new Name, so that
--   we are totally out of Meta-tyvar-land
-- We create a skolem TyVar, not a regular TyVar
--   See Note [Zonking to Skolem]
skolemiseUnboundMetaTyVar tv details
  = ASSERT2( isMetaTyVar tv, ppr tv ) 
    do  { span <- getSrcSpanM    -- Get the location from "here"
                                 -- ie where we are generalising
        ; uniq <- newUnique      -- Remove it from TcMetaTyVar unique land
	; let final_kind = defaultKind (tyVarKind tv)
              final_name = mkInternalName uniq (getOccName tv) span
              final_tv   = mkTcTyVar final_name final_kind details
	; writeMetaTyVar tv (mkTyVarTy final_tv)
	; return final_tv }

zonkImplication :: Implication -> TcM Implication
zonkImplication implic@(Implic { ic_given = given 
                               , ic_wanted = wanted
                               , ic_loc = loc })
  = do {    -- No need to zonk the skolems
       ; given'  <- mapM zonkEvVar given
       ; loc'    <- zonkGivenLoc loc
       ; wanted' <- zonkWC wanted
       ; return (implic { ic_given = given'
                        , ic_wanted = wanted'
                        , ic_loc = loc' }) }

zonkEvVar :: EvVar -> TcM EvVar
zonkEvVar var = do { ty' <- zonkTcType (varType var)
                   ; return (setVarType var ty') }

zonkFlavoredEvVar :: FlavoredEvVar -> TcM FlavoredEvVar
zonkFlavoredEvVar (EvVarX ev fl)
  = do { ev' <- zonkEvVar ev
       ; fl' <- zonkFlavor fl
       ; return (EvVarX ev' fl') }

zonkWC :: WantedConstraints -> TcM WantedConstraints
zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
  = do { flat'   <- zonkWantedEvVars flat
       ; implic' <- mapBagM zonkImplication implic
       ; insol'  <- mapBagM zonkFlavoredEvVar insol
       ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) }

zonkWantedEvVars :: Bag WantedEvVar -> TcM (Bag WantedEvVar)
zonkWantedEvVars = mapBagM zonkWantedEvVar

zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }

zonkFlavor :: CtFlavor -> TcM CtFlavor
zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
zonkFlavor fl          = return fl

zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
zonkGivenLoc (CtLoc skol_info span ctxt)
  = do { skol_info' <- zonkSkolemInfo skol_info
       ; return (CtLoc skol_info' span ctxt) }

zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo (SigSkol cx ty)  = do { ty' <- zonkTcType ty
                                     ; return (SigSkol cx ty') }
zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
                                     ; return (InferSkol ntys') }
  where
    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
zonkSkolemInfo skol_info = return skol_info

-- For unbound, mutable tyvars, zonkType uses the function given to it
-- For tyvars bound at a for-all, zonkType zonks them to an immutable
--	type variable and zonks the kind too

zonkType :: (TcTyVar -> TcM Type)  -- What to do with TcTyVars
         -> TcType -> TcM Type
zonkType zonk_tc_tyvar ty
  = go ty
  where
    go (TyConApp tc tys) = do tys' <- mapM go tys
                              return (TyConApp tc tys')

    go (PredTy p)        = do p' <- go_pred p
                              return (PredTy p')

    go (FunTy arg res)   = do arg' <- go arg
                              res' <- go res
                              return (FunTy arg' res')

    go (AppTy fun arg)   = do fun' <- go fun
                              arg' <- go arg
                              return (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.

	-- The two interesting cases!
    go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
		       | otherwise	 = liftM TyVarTy $ 
                                           zonkTyVar zonk_tc_tyvar tyvar
		-- Ordinary (non Tc) tyvars occur inside quantified types

    go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                             ty' <- go ty
                             tyvar' <- zonkTyVar zonk_tc_tyvar tyvar
                             return (ForAllTy tyvar' ty')

    go_pred (ClassP c tys)   = do tys' <- mapM go tys
                                  return (ClassP c tys')
    go_pred (IParam n ty)    = do ty' <- go ty
                                  return (IParam n ty')
    go_pred (EqPred ty1 ty2) = do ty1' <- go ty1
                                  ty2' <- go ty2
                                  return (EqPred ty1' ty2')

mkZonkTcTyVar :: (TcTyVar -> TcM Type)	-- What to do for an *mutable Flexi* var
 	      -> TcTyVar -> TcM TcType
mkZonkTcTyVar unbound_var_fn tyvar 
  = ASSERT( isTcTyVar tyvar )
    case tcTyVarDetails tyvar of
      SkolemTv {}    -> return (TyVarTy tyvar)
      RuntimeUnk {}  -> return (TyVarTy tyvar)
      FlatSkol ty    -> zonkType (mkZonkTcTyVar unbound_var_fn) ty
      MetaTv _ ref   -> do { cts <- readMutVar ref
			   ; case cts of    
			       Flexi       -> unbound_var_fn tyvar  
			       Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }

-- Zonk the kind of a non-TC tyvar in case it is a coercion variable 
-- (their kind contains types).
zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for a TcTyVar
 	  -> TyVar -> TcM TyVar
zonkTyVar zonk_tc_tyvar tv 
  | isCoVar tv
  = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv)
       ; return $ setTyVarKind tv kind }
  | otherwise = return tv

readKindVar  :: KindVar -> TcM (MetaDetails)
writeKindVar :: KindVar -> TcKind -> TcM ()
readKindVar  kv = readMutVar (kindVarRef kv)
writeKindVar kv val = writeMutVar (kindVarRef kv) (Indirect val)

-------------
zonkTcKind :: TcKind -> TcM TcKind
zonkTcKind k = zonkTcType k

-------------
zonkTcKindToKind :: TcKind -> TcM 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 (mkZonkTcTyVar (\ _ -> return liftedTypeKind)) k

checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that the type is valid for the given context
checkValidType ctxt ty = do
    traceTc "checkValidType" (ppr ty)
    unboxed  <- xoptM Opt_UnboxedTuples
    rank2    <- xoptM Opt_Rank2Types
    rankn    <- xoptM Opt_RankNTypes
    polycomp <- xoptM Opt_PolymorphicComponents
    let 
	gen_rank n | rankn     = ArbitraryRank
	           | rank2     = Rank 2
	           | otherwise = Rank n
	rank
	  = case ctxt of
		 DefaultDeclCtxt-> MustBeMonoType
		 ResSigCtxt	-> MustBeMonoType
		 LamPatSigCtxt	-> gen_rank 0
		 BindPatSigCtxt	-> gen_rank 0
		 TySynCtxt _    -> gen_rank 0
		 GenPatCtxt	-> gen_rank 1
			-- This one is a bit of a hack
			-- See the forall-wrapping in TcClassDcl.mkGenericInstance		

		 ExprSigCtxt 	-> gen_rank 1
		 FunSigCtxt _   -> gen_rank 1
		 ConArgCtxt _   | polycomp -> gen_rank 2
                                -- We are given the type of the entire
                                -- constructor, hence rank 1
 				| otherwise -> gen_rank 1

		 ForSigCtxt _	-> gen_rank 1
		 SpecInstCtxt   -> gen_rank 1
                 ThBrackCtxt    -> gen_rank 1
                 GenSigCtxt     -> panic "checkValidType"
                                     -- Can't happen; GenSigCtxt not used for *user* sigs

	actual_kind = typeKind ty

	kind_ok = case ctxt of
			TySynCtxt _  -> True -- Any kind will do
			ThBrackCtxt  -> True -- Any kind will do
			ResSigCtxt   -> isSubOpenTypeKind actual_kind
			ExprSigCtxt  -> isSubOpenTypeKind actual_kind
			GenPatCtxt   -> isLiftedTypeKind actual_kind
			ForSigCtxt _ -> isLiftedTypeKind actual_kind
			_            -> isSubArgTypeKind actual_kind
	
	ubx_tup = case ctxt of
	              TySynCtxt _ | unboxed -> UT_Ok
	              ExprSigCtxt | unboxed -> UT_Ok
	              ThBrackCtxt | unboxed -> UT_Ok
	              _                     -> UT_NotOk

	-- Check the internal validity of the type itself
    check_type rank ubx_tup ty

	-- Check that the thing has kind Type, and is lifted if necessary
	-- Do this second, becuase we can't usefully take the kind of an 
	-- ill-formed type such as (a~Int)
    checkTc kind_ok (kindErr actual_kind)

    traceTc "checkValidType done" (ppr ty)

checkValidMonoType :: Type -> TcM ()
checkValidMonoType ty = check_mono_type MustBeMonoType ty

data Rank = ArbitraryRank	  -- Any rank ok
          | MustBeMonoType  	  -- Monotype regardless of flags
	  | TyConArgMonoType	  -- Monotype but could be poly if -XImpredicativeTypes
	  | SynArgMonoType	  -- Monotype but could be poly if -XLiberalTypeSynonyms
          | Rank Int		  -- Rank n, but could be more with -XRankNTypes

decRank :: Rank -> Rank		  -- Function arguments
decRank (Rank 0)   = Rank 0
decRank (Rank n)   = Rank (n-1)
decRank other_rank = other_rank

nonZeroRank :: Rank -> Bool
nonZeroRank ArbitraryRank = True
nonZeroRank (Rank n) 	  = n>0
nonZeroRank _        	  = False

----------------------------------------
data UbxTupFlag = UT_Ok	| UT_NotOk
	-- The "Ok" version means "ok if UnboxedTuples is on"

----------------------------------------
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)

----------------------------------------
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 <- xoptM Opt_ImpredicativeTypes
	; let rank' = case rank of 	    -- Predictive => must be monotype
	      	        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
			_other | impred    -> ArbitraryRank
			       | otherwise -> TyConArgMonoType
			-- Make sure that MustBeMonoType is propagated, 
			-- so that we don't suggest -XImpredicativeTypes in
			--    (Ord (forall a.a)) => a -> a
			-- and so that if it Must be a monotype, we check that it is!

	; check_type rank' UT_NotOk ty
	; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }

----------------------------------------
forAllTyErr :: Rank -> Type -> SDoc
forAllTyErr rank ty 
   = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty)
          , suggestion ]
  where
    suggestion = case rank of
    	       	   Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")
    	       	   TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes")
    	       	   SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms")
		   _ -> empty      -- Polytype is always illegal

unliftedArgErr, ubxArgTyErr :: Type -> SDoc
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 -> SDoc
kindErr kind       = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind]

-- Enumerate the contexts in which a "source type", <S>, can occur
--	Eq a 
-- or 	?x::Int
-- or 	r <: {x::Int}
-- or 	(N a) where N is a newtype

data SourceTyCtxt
  = ClassSCCtxt Name	-- Superclasses of clas
			-- 	class <S> => C a where ...
  | SigmaCtxt		-- Theta part of a normal for-all type
			--	f :: <S> => a -> a
  | DataTyCtxt Name	-- Theta part of a data decl
			--	data <S> => T a = MkT a
  | TypeCtxt 		-- Source type in an ordinary type
			-- 	f :: N a -> N a
  | InstThetaCtxt	-- Context of an instance decl
			--	instance <S> => C [a] where ...
		
pprSourceTyCtxt :: SourceTyCtxt -> SDoc
pprSourceTyCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
pprSourceTyCtxt SigmaCtxt       = ptext (sLit "the context of a polymorphic type")
pprSourceTyCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
pprSourceTyCtxt InstThetaCtxt   = ptext (sLit "the context of an instance declaration")
pprSourceTyCtxt TypeCtxt        = ptext (sLit "the context of a type")

checkValidTheta :: SourceTyCtxt -> ThetaType -> TcM ()
checkValidTheta ctxt theta 
  = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)

-------------------------
check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM ()
check_valid_theta _ []
  = return ()
check_valid_theta ctxt theta = do
    dflags <- getDOpts
    warnTc (notNull dups) (dupPredWarn dups)
    mapM_ (check_pred_ty dflags ctxt) theta
  where
    (_,dups) = removeDups tcCmpPred theta

-------------------------
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
       ; mapM_ checkValidMonoType 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 -XFlexibleContexts to permit this"))


check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
  = do {	-- Equational constraints are valid in all contexts if type
		-- families are permitted
       ; checkTc (xopt Opt_TypeFamilies dflags) (eqPredTyErr pred)
       ; checkTc (case ctxt of ClassSCCtxt {} -> False; _ -> True)
                 (eqSuperClassErr pred)

		-- Check the form of the argument types
       ; checkValidMonoType ty1
       ; checkValidMonoType ty2
       }

check_pred_ty _ SigmaCtxt (IParam _ ty) = checkValidMonoType 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.
	-- 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
	-- constraint Foo [Int] might come out of e,and applying the
	-- instance decl would show up two uses of ?x.

-- Catch-all
check_pred_ty _ _ 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 -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
				-- Further checks on head and theta in
				-- checkInstTermination
	_             -> flexible_contexts || all tyvar_head tys
  where
    flexible_contexts = xopt Opt_FlexibleContexts dflags
    undecidable_ok = xopt Opt_UndecidableInstances dflags

-------------------------
tyvar_head :: Type -> Bool
tyvar_head ty			-- Haskell 98 allows predicates of form 
  | tcIsTyVarTy ty = True	-- 	C (a ty1 .. tyn)
  | otherwise			-- where a is a type variable
  = case tcSplitAppTy_maybe ty of
	Just (ty, _) -> tyvar_head ty
	Nothing	     -> False

checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
checkAmbiguity forall_tyvars theta tau_tyvars
  = mapM_ complain (filter is_ambig theta)
  where
    complain pred     = addErrTc (ambigErr pred)
    extended_tau_vars = growThetaTyVars theta tau_tyvars

	-- See Note [Implicit parameters and ambiguity] in TcSimplify
    is_ambig pred     = isClassPred  pred &&
			any ambig_var (varSetElems (tyVarsOfPred pred))

    ambig_var ct_var  = (ct_var `elem` forall_tyvars) &&
		        not (ct_var `elemVarSet` extended_tau_vars)

ambigErr :: PredType -> SDoc
ambigErr pred
  = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
	 nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
		 ptext (sLit "must be reachable from the type after the '=>'"))]

growThetaTyVars :: TcThetaType -> TyVarSet -> TyVarSet
-- See Note [Growing the tau-tvs using constraints]
growThetaTyVars theta tvs
  | null theta = tvs
  | otherwise  = fixVarSet mk_next tvs
  where
    mk_next tvs = foldr grow_one tvs theta
    grow_one pred tvs = growPredTyVars pred tvs `unionVarSet` tvs

growPredTyVars :: TcPredType
               -> TyVarSet	-- The set to extend
	       -> TyVarSet	-- TyVars of the predicate if it intersects
	       	  		-- the set, or is implicit parameter
growPredTyVars pred tvs 
  | IParam {} <- pred               = pred_tvs	-- See Note [Implicit parameters and ambiguity]
  | pred_tvs `intersectsVarSet` tvs = pred_tvs
  | otherwise                       = emptyVarSet
  where
    pred_tvs = tyVarsOfPred pred

checkThetaCtxt :: SourceTyCtxt -> ThetaType -> SDoc
checkThetaCtxt ctxt theta
  = vcat [ptext (sLit "In the context:") <+> pprTheta theta,
	  ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ]

eqSuperClassErr :: PredType -> SDoc
eqSuperClassErr pred
  = hang (ptext (sLit "Alas, GHC 7.0 still cannot handle equality superclasses:"))
       2 (ppr pred)

badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc
badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred
eqPredTyErr  pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred
		    $$
		    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 :: [[PredType]] -> SDoc
dupPredWarn dups   = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)

arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
arityErr kind name n m
  = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"),
	   n_arguments <> comma, text "but has been given", 
           if m==0 then text "none" else int m]
    where
	n_arguments | n == 0 = ptext (sLit "no arguments")
		    | n == 1 = ptext (sLit "1 argument")
		    | True   = hsep [int n, ptext (sLit "arguments")]

checkValidInstHead :: Class -> [Type] -> TcM ()
checkValidInstHead clas tys
  = do { dflags <- getDOpts

           -- If GlasgowExts then check at least one isn't a type variable
       ; checkTc (xopt Opt_TypeSynonymInstances dflags ||
                  all tcInstHeadTyNotSynonym tys)
                 (instTypeErr pp_pred head_type_synonym_msg)
       ; checkTc (xopt Opt_FlexibleInstances dflags ||
                  all tcInstHeadTyAppAllTyVars tys)
                 (instTypeErr pp_pred head_type_args_tyvars_msg)
       ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
                  isSingleton tys)
                 (instTypeErr pp_pred head_one_type_msg)
         -- May not contain type family applications
       ; mapM_ checkTyFamFreeness tys

       ; mapM_ checkValidMonoType 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
       }

  where
    pp_pred = pprClassPred clas tys
    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 (vcat [
                text "All instance types must be of the form (T a1 ... an)",
                text "where a1 ... an are *distinct 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." $$
                text "Use -XMultiParamTypeClasses if you want to allow more.")

instTypeErr :: SDoc -> SDoc -> SDoc
instTypeErr pp_ty msg
  = sep [ptext (sLit "Illegal instance declaration for") <+> quotes pp_ty, 
	 nest 2 msg]

checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType
                   -> Class -> [TcType] -> TcM ()
checkValidInstance hs_type tyvars theta clas inst_tys
  = setSrcSpan (getLoc hs_type) $
    do  { setSrcSpan head_loc (checkValidInstHead clas inst_tys)
        ; checkValidTheta InstThetaCtxt theta
	; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)

	-- Check that instance inference will terminate (if we care)
	-- For Haskell 98 this will already have been done by checkValidTheta,
        -- but as we may be using other extensions we need to check.
	; undecidable_ok <- xoptM Opt_UndecidableInstances
        ; 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 (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
			 undecidableMsg])

        -- The location of the "head" of the instance
    head_loc = case hs_type of
                 L _ (HsForAllTy _ _ _ (L loc _)) -> loc
                 L loc _                          -> loc

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 :: PredType -> SDoc -> SDoc
predUndecErr pred msg = sep [msg,
			nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]

nomoreMsg, smallerMsg, undecidableMsg :: SDoc
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 -XUndecidableInstances to permit this")

validDerivPred :: PredType -> Bool
validDerivPred (ClassP _ tys) = hasNoDups fvs && sizeTypes tys == length fvs
                              where fvs = fvTypes tys
validDerivPred _              = False

-- Check that a "type instance" is well-formed (which includes decidability
-- unless -XUndecidableInstances is given).
--
checkValidTypeInst :: [Type] -> Type -> TcM ()
checkValidTypeInst typats rhs
  = do { -- left-hand side contains no type family applications
         -- (vanilla synonyms are fine, though)
       ; mapM_ checkTyFamFreeness typats

         -- the right-hand side is a tau type
       ; checkValidMonoType rhs

         -- we have a decidable instance unless otherwise permitted
       ; undecidable_ok <- xoptM 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) $
      tyFamInstIllegalErr ty

-- Check that a type does not contain any type family applications.
--
isTyFamFree :: Type -> Bool
isTyFamFree = null . tyFamInsts

-- Error messages

tyFamInstIllegalErr :: Type -> SDoc
tyFamInstIllegalErr ty
  = hang (ptext (sLit "Illegal type synonym family application in instance") <> 
         colon) 2 $
      ppr ty

famInstUndecErr :: Type -> SDoc -> SDoc
famInstUndecErr ty msg 
  = sep [msg, 
         nest 2 (ptext (sLit "in the type family application:") <+> 
                 pprType ty)]

nestedMsg, nomoreVarMsg, smallerAppMsg :: SDoc
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")

-- Free variables of a type, retaining repetitions, and expanding synonyms
fvType :: Type -> [TyVar]
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvType (TyVarTy tv)        = [tv]
fvType (TyConApp _ tys)    = fvTypes tys
fvType (PredTy pred)       = fvPred pred
fvType (FunTy arg res)     = fvType arg ++ fvType res
fvType (AppTy fun arg)     = fvType fun ++ fvType arg
fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)

fvTypes :: [Type] -> [TyVar]
fvTypes tys                = concat (map fvType tys)

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
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
sizeType (TyVarTy _)       = 1
sizeType (TyConApp _ tys)  = sizeTypes tys + 1
sizeType (PredTy pred)     = sizePred pred
sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
sizeType (ForAllTy _ ty)   = sizeType ty

sizeTypes :: [Type] -> Int
sizeTypes xs               = sum (map sizeType xs)

-- Size of a predicate
--
-- We are considering whether *class* constraints terminate
-- Once we get into an implicit parameter or equality we
-- can't get back to a class constraint, so it's safe
-- to say "size 0".  See Trac #4200.
sizePred :: PredType -> Int
sizePred (ClassP _ tys')   = sizeTypes tys'
sizePred (IParam {})       = 0
sizePred (EqPred {})       = 0