ghc/compiler/typecheck/TcMonoType.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
   5
   6 \begin{code}
   7 module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType,
   8                     tcContext, tcHsTyVar, kcHsTyVar,
   9                     tcExtendTyVarScope, tcExtendTopTyVarScope,
  10                     TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig,
  11                     checkSigTyVars, sigCtxt, sigPatCtxt
  12                   ) where
  13
  14 #include "HsVersions.h"
  15
  16 import HsSyn            ( HsType(..), HsTyVar(..), Sig(..), pprClassAssertion, pprParendHsType )
  17 import RnHsSyn          ( RenamedHsType, RenamedContext, RenamedSig )
  18 import TcHsSyn          ( TcId )
  19
  20 import TcMonad
  21 import TcEnv            ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
  22                           tcGetGlobalTyVars, TcTyThing(..)
  23                         )
  24 import TcType           ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
  25                           typeToTcType, tcInstTcType, kindToTcKind,
  26                           newKindVar,
  27                           zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType
  28                         )
  29 import Inst             ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
  30 import TcUnify          ( unifyKind, unifyKinds, unifyTypeKind )
  31 import Type             ( Type, ThetaType,
  32                           mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys,
  33                           mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitRhoTy,
  34                           boxedTypeKind, unboxedTypeKind, tyVarsOfType,
  35                           mkArrowKinds, getTyVar_maybe, getTyVar,
  36                           tidyOpenType, tidyOpenTypes, tidyTyVar
  37                         )
  38 import Id               ( mkUserId, idName, idType, idFreeTyVars )
  39 import Var              ( TyVar, mkTyVar )
  40 import VarEnv
  41 import VarSet
  42 import Bag              ( bagToList )
  43 import ErrUtils         ( Message )
  44 import PrelInfo         ( cCallishClassKeys )
  45 import TyCon            ( TyCon )
  46 import Name             ( Name, OccName, isLocallyDefined )
  47 import TysWiredIn       ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
  48 import SrcLoc           ( SrcLoc )
  49 import Unique           ( Unique, Uniquable(..) )
  50 import UniqFM           ( eltsUFM )
  51 import Util             ( zipWithEqual, zipLazy, mapAccumL )
  52 import Outputable
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{Checking types}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 tcHsType and tcHsTypeKind
  63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  64
  65 tcHsType checks that the type really is of kind Type!
  66
  67 \begin{code}
  68 tcHsType :: RenamedHsType -> TcM s TcType
  69 tcHsType ty
  70   = -- tcAddErrCtxt (typeCtxt ty)               $
  71     tc_type ty
  72
  73 tcHsTypeKind    :: RenamedHsType -> TcM s (TcKind, TcType)
  74 tcHsTypeKind ty
  75   = -- tcAddErrCtxt (typeCtxt ty)               $
  76     tc_type_kind ty
  77
  78 -- Type-check a type, *and* then lazily zonk it.  The important
  79 -- point is that this zonks all the uncommitted *kind* variables
  80 -- in kinds of any any nested for-all tyvars.
  81 -- There won't be any mutable *type* variables at all.
  82 --
  83 -- NOTE the forkNF_Tc.  This makes the zonking lazy, which is
  84 -- absolutely necessary.  During the type-checking of a recursive
  85 -- group of tycons/classes (TcTyClsDecls.tcGroup) we use an
  86 -- environment in which we aren't allowed to look at the actual
  87 -- tycons/classes returned from a lookup. Because tc_app does
  88 -- look at the tycon to build the type, we can't look at the type
  89 -- either, until we get out of the loop.   The fork delays the
  90 -- zonking till we've completed the loop.  Sigh.
  91
  92 tcHsTopType :: RenamedHsType -> TcM s Type
  93 tcHsTopType ty
  94   = -- tcAddErrCtxt (typeCtxt ty)               $
  95     tc_type ty                          `thenTc` \ ty' ->
  96     forkNF_Tc (zonkTcTypeToType ty')
  97
  98 tcHsTopBoxedType :: RenamedHsType -> TcM s Type
  99 tcHsTopBoxedType ty
 100   = -- tcAddErrCtxt (typeCtxt ty)               $
 101     tc_boxed_type ty                    `thenTc` \ ty' ->
 102     forkNF_Tc (zonkTcTypeToType ty')
 103 \end{code}
 104
 105
 106 The main work horse
 107 ~~~~~~~~~~~~~~~~~~~
 108
 109 \begin{code}
 110 tc_boxed_type :: RenamedHsType -> TcM s Type
 111 tc_boxed_type ty
 112   = tc_type_kind ty                                     `thenTc` \ (actual_kind, tc_ty) ->
 113     tcAddErrCtxt (typeKindCtxt ty)
 114                  (unifyKind boxedTypeKind actual_kind)  `thenTc_`
 115     returnTc tc_ty
 116
 117 tc_type :: RenamedHsType -> TcM s Type
 118 tc_type ty
 119         -- The type ty must be a *type*, but it can be boxed
 120         -- or unboxed.  So we check that is is of form (Type bv)
 121         -- using unifyTypeKind
 122   = tc_type_kind ty                             `thenTc` \ (actual_kind, tc_ty) ->
 123     tcAddErrCtxt (typeKindCtxt ty)
 124                  (unifyTypeKind actual_kind)    `thenTc_`
 125     returnTc tc_ty
 126
 127 tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
 128 tc_type_kind ty@(MonoTyVar name)
 129   = tc_app ty []
 130
 131 tc_type_kind (MonoListTy ty)
 132   = tc_boxed_type ty            `thenTc` \ tau_ty ->
 133     returnTc (boxedTypeKind, mkListTy tau_ty)
 134
 135 tc_type_kind (MonoTupleTy tys True {-boxed-})
 136   = mapTc tc_boxed_type tys     `thenTc` \ tau_tys ->
 137     returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
 138
 139 tc_type_kind (MonoTupleTy tys False {-unboxed-})
 140   = mapTc tc_type tys                   `thenTc` \ tau_tys ->
 141     returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
 142
 143 tc_type_kind (MonoFunTy ty1 ty2)
 144   = tc_type ty1 `thenTc` \ tau_ty1 ->
 145     tc_type ty2 `thenTc` \ tau_ty2 ->
 146     returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
 147
 148 tc_type_kind (MonoTyApp ty1 ty2)
 149   = tc_app ty1 [ty2]
 150
 151 tc_type_kind (MonoDictTy class_name tys)
 152   = tcClassAssertion (class_name, tys)  `thenTc` \ (clas, arg_tys) ->
 153     returnTc (boxedTypeKind, mkDictTy clas arg_tys)
 154
 155 tc_type_kind (HsForAllTy (Just tv_names) context ty)
 156   = tcExtendTyVarScope tv_names         $ \ tyvars ->
 157     tcContext context                   `thenTc` \ theta ->
 158     tc_boxed_type ty                    `thenTc` \ tau ->
 159                 -- Body of a for-all is a boxed type!
 160     returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
 161 \end{code}
 162
 163 Help functions for type applications
 164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 165
 166 \begin{code}
 167 tc_app (MonoTyApp ty1 ty2) tys
 168   = tc_app ty1 (ty2:tys)
 169
 170 tc_app ty tys
 171   | null tys
 172   = tc_fun_type ty []
 173
 174   | otherwise
 175   = tcAddErrCtxt (appKindCtxt pp_app)   $
 176     mapAndUnzipTc tc_type_kind tys      `thenTc` \ (arg_kinds, arg_tys) ->
 177     tc_fun_type ty arg_tys              `thenTc` \ (fun_kind, result_ty) ->
 178
 179         -- Check argument compatibility
 180     newKindVar                                  `thenNF_Tc` \ result_kind ->
 181     unifyKind fun_kind (mkArrowKinds arg_kinds result_kind)
 182                                         `thenTc_`
 183     returnTc (result_kind, result_ty)
 184   where
 185     pp_app = ppr ty <+> sep (map pprParendHsType tys)
 186
 187 -- (tc_fun_type ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
 188 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
 189 --      hence the rather strange functionality.
 190
 191 tc_fun_type (MonoTyVar name) arg_tys
 192   = tcLookupTy name                     `thenTc` \ (tycon_kind, maybe_arity, thing) ->
 193     case thing of
 194         ATyVar tv   -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys)
 195         AClass clas -> failWithTc (classAsTyConErr name)
 196         ATyCon tc   -> case maybe_arity of
 197                          Nothing ->     -- Data or newtype
 198                                         returnTc (tycon_kind, mkTyConApp tc arg_tys)
 199
 200                          Just arity ->  -- Type synonym
 201                                   checkTc (arity <= n_args) err_msg     `thenTc_`
 202                                   returnTc (tycon_kind, result_ty)
 203                            where
 204                                 -- It's OK to have an *over-applied* type synonym
 205                                 --      data Tree a b = ...
 206                                 --      type Foo a = Tree [a]
 207                                 --      f :: Foo a b -> ...
 208                               result_ty = mkAppTys (mkSynTy tc (take arity arg_tys))
 209                                                    (drop arity arg_tys)
 210                               err_msg = arityErr "type synonym" name arity n_args
 211                               n_args  = length arg_tys
 212
 213 tc_fun_type ty arg_tys
 214   = tc_type_kind ty             `thenTc` \ (fun_kind, fun_ty) ->
 215     returnTc (fun_kind, mkAppTys fun_ty arg_tys)
 216 \end{code}
 217
 218
 219 Contexts
 220 ~~~~~~~~
 221 \begin{code}
 222
 223 tcContext :: RenamedContext -> TcM s ThetaType
 224 tcContext context
 225   =     --Someone discovered that @CCallable@ and @CReturnable@
 226         -- could be used in contexts such as:
 227         --      foo :: CCallable a => a -> PrimIO Int
 228         -- Doing this utterly wrecks the whole point of introducing these
 229         -- classes so we specifically check that this isn't being done.
 230         --
 231         -- We *don't* do this check in tcClassAssertion, because that's
 232         -- called when checking a HsDictTy, and we don't want to reject
 233         --      instance CCallable Int
 234         -- etc. Ugh!
 235     mapTc check_naughty context `thenTc_`
 236
 237     mapTc tcClassAssertion context
 238
 239  where
 240    check_naughty (class_name, _)
 241      = checkTc (not (getUnique class_name `elem` cCallishClassKeys))
 242                (naughtyCCallContextErr class_name)
 243
 244 tcClassAssertion assn@(class_name, tys)
 245   = tcAddErrCtxt (appKindCtxt (pprClassAssertion assn)) $
 246     mapAndUnzipTc tc_type_kind tys      `thenTc` \ (arg_kinds, arg_tys) ->
 247     tcLookupTy class_name               `thenTc` \ (kind, ~(Just arity), thing) ->
 248     case thing of
 249         ATyVar  _   -> failWithTc (tyVarAsClassErr class_name)
 250         ATyCon  _   -> failWithTc (tyConAsClassErr class_name)
 251         AClass clas ->
 252                         -- Check with kind mis-match
 253                 checkTc (arity == n_tys) err                            `thenTc_`
 254                 unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind)   `thenTc_`
 255                 returnTc (clas, arg_tys)
 256             where
 257                 n_tys = length tys
 258                 err   = arityErr "Class" class_name arity n_tys
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{Type variables, with knot tying!}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name]
 270                       -> ([TcTyVar] -> TcKind -> TcM s a)
 271                       -> TcM s a
 272 tcExtendTopTyVarScope kind tyvar_names thing_inside
 273   = let
 274         (tyvars_w_kinds, result_kind) = zipFunTys tyvar_names kind
 275         tyvars                        = map mk_tv tyvars_w_kinds
 276     in
 277     tcExtendTyVarEnv tyvars (thing_inside tyvars result_kind)
 278   where
 279     mk_tv (UserTyVar name,    kind) = mkTyVar name kind
 280     mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind
 281         -- NB: immutable tyvars, but perhaps with mutable kinds
 282
 283 tcExtendTyVarScope :: [HsTyVar Name]
 284                    -> ([TcTyVar] -> TcM s a) -> TcM s a
 285 tcExtendTyVarScope tv_names thing_inside
 286   = mapNF_Tc tcHsTyVar tv_names         `thenNF_Tc` \ tyvars ->
 287     tcExtendTyVarEnv tyvars             $
 288     thing_inside tyvars
 289
 290 tcHsTyVar :: HsTyVar Name -> NF_TcM s TcTyVar
 291 tcHsTyVar (UserTyVar name)       = newKindVar           `thenNF_Tc` \ kind ->
 292                                    tcNewMutTyVar name kind
 293         -- NB: mutable kind => mutable tyvar, so that zonking can bind
 294         -- the tyvar to its immutable form
 295
 296 tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind))
 297
 298 kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind
 299 kcHsTyVar (UserTyVar name)       = newKindVar
 300 kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind)
 301 \end{code}
 302
 303
 304 %************************************************************************
 305 %*                                                                      *
 306 \subsection{Signatures}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 @tcSigs@ checks the signatures for validity, and returns a list of
 311 {\em freshly-instantiated} signatures.  That is, the types are already
 312 split up, and have fresh type variables installed.  All non-type-signature
 313 "RenamedSigs" are ignored.
 314
 315 The @TcSigInfo@ contains @TcTypes@ because they are unified with
 316 the variable's type, and after that checked to see whether they've
 317 been instantiated.
 318
 319 \begin{code}
 320 data TcSigInfo
 321   = TySigInfo
 322         Name                    -- N, the Name in corresponding binding
 323
 324         TcId                    -- *Polymorphic* binder for this value...
 325                                 -- Has name = N
 326
 327         [TcTyVar]               -- tyvars
 328         TcThetaType             -- theta
 329         TcTauType               -- tau
 330
 331         TcId                    -- *Monomorphic* binder for this value
 332                                 -- Does *not* have name = N
 333                                 -- Has type tau
 334
 335         Inst                    -- Empty if theta is null, or
 336                                 -- (method mono_id) otherwise
 337
 338         SrcLoc                  -- Of the signature
 339
 340
 341 maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
 342         -- Search for a particular signature
 343 maybeSig [] name = Nothing
 344 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
 345   | name == sig_name = Just sig
 346   | otherwise        = maybeSig sigs name
 347
 348 -- This little helper is useful to pass to tcPat
 349 noSigs :: Name -> Maybe TcId
 350 noSigs name = Nothing
 351 \end{code}
 352
 353
 354 \begin{code}
 355 tcTySig :: RenamedSig -> TcM s TcSigInfo
 356
 357 tcTySig (Sig v ty src_loc)
 358  = tcAddSrcLoc src_loc $
 359    tcHsType ty                                  `thenTc` \ sigma_tc_ty ->
 360    mkTcSig (mkUserId v sigma_tc_ty) src_loc     `thenNF_Tc` \ sig ->
 361    returnTc sig
 362
 363 mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo
 364 mkTcSig poly_id src_loc
 365   =     -- Instantiate this type
 366         -- It's important to do this even though in the error-free case
 367         -- we could just split the sigma_tc_ty (since the tyvars don't
 368         -- unified with anything).  But in the case of an error, when
 369         -- the tyvars *do* get unified with something, we want to carry on
 370         -- typechecking the rest of the program with the function bound
 371         -- to a pristine type, namely sigma_tc_ty
 372    tcInstTcType (idType poly_id)                `thenNF_Tc` \ (tyvars, rho) ->
 373    let
 374      (theta, tau) = splitRhoTy rho
 375         -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
 376         -- wherever possible, which can improve interface files.
 377    in
 378    newMethodWithGivenTy SignatureOrigin
 379                 poly_id
 380                 (mkTyVarTys tyvars)
 381                 theta tau                       `thenNF_Tc` \ inst ->
 382         -- We make a Method even if it's not overloaded; no harm
 383
 384    returnNF_Tc (TySigInfo name poly_id tyvars theta tau (instToIdBndr inst) inst src_loc)
 385   where
 386     name = idName poly_id
 387 \end{code}
 388
 389
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection{Checking signature type variables}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 @checkSigTyVars@ is used after the type in a type signature has been unified with
 398 the actual type found.  It then checks that the type variables of the type signature
 399 are
 400         (a) Still all type variables
 401                 eg matching signature [a] against inferred type [(p,q)]
 402                 [then a will be unified to a non-type variable]
 403
 404         (b) Still all distinct
 405                 eg matching signature [(a,b)] against inferred type [(p,p)]
 406                 [then a and b will be unified together]
 407
 408         (c) Not mentioned in the environment
 409                 eg the signature for f in this:
 410
 411                         g x = ... where
 412                                         f :: a->[a]
 413                                         f y = [x,y]
 414
 415                 Here, f is forced to be monorphic by the free occurence of x.
 416
 417         (d) Not (unified with another type variable that is) in scope.
 418                 eg f x :: (r->r) = (\y->y) :: forall a. a->r
 419             when checking the expression type signature, we find that
 420             even though there is nothing in scope whose type mentions r,
 421             nevertheless the type signature for the expression isn't right.
 422
 423             Another example is in a class or instance declaration:
 424                 class C a where
 425                    op :: forall b. a -> b
 426                    op x = x
 427             Here, b gets unified with a
 428
 429 Before doing this, the substitution is applied to the signature type variable.
 430
 431 We used to have the notion of a "DontBind" type variable, which would
 432 only be bound to itself or nothing.  Then points (a) and (b) were
 433 self-checking.  But it gave rise to bogus consequential error messages.
 434 For example:
 435
 436    f = (*)      -- Monomorphic
 437
 438    g :: Num a => a -> a
 439    g x = f x x
 440
 441 Here, we get a complaint when checking the type signature for g,
 442 that g isn't polymorphic enough; but then we get another one when
 443 dealing with the (Num x) context arising from f's definition;
 444 we try to unify x with Int (to default it), but find that x has already
 445 been unified with the DontBind variable "a" from g's signature.
 446 This is really a problem with side-effecting unification; we'd like to
 447 undo g's effects when its type signature fails, but unification is done
 448 by side effect, so we can't (easily).
 449
 450 So we revert to ordinary type variables for signatures, and try to
 451 give a helpful message in checkSigTyVars.
 452
 453 \begin{code}
 454 checkSigTyVars :: [TcTyVar]             -- The original signature type variables
 455                -> TcM s [TcTyVar]       -- Zonked signature type variables
 456
 457 checkSigTyVars [] = returnTc []
 458
 459 checkSigTyVars sig_tyvars
 460   = zonkTcTyVars sig_tyvars             `thenNF_Tc` \ sig_tys ->
 461     tcGetGlobalTyVars                   `thenNF_Tc` \ globals ->
 462
 463     checkTcM (all_ok sig_tys globals)
 464              (complain sig_tys globals) `thenTc_`
 465
 466     returnTc (map (getTyVar "checkSigTyVars") sig_tys)
 467
 468   where
 469     all_ok []       acc = True
 470     all_ok (ty:tys) acc = case getTyVar_maybe ty of
 471                             Nothing                       -> False      -- Point (a)
 472                             Just tv | tv `elemVarSet` acc -> False      -- Point (b) or (c)
 473                                     | otherwise           -> all_ok tys (acc `extendVarSet` tv)
 474
 475
 476     complain sig_tys globals
 477       = -- For the in-scope ones, zonk them and construct a map
 478         -- from the zonked tyvar to the in-scope one
 479         -- If any of the in-scope tyvars zonk to a type, then ignore them;
 480         -- that'll be caught later when we back up to their type sig
 481         tcGetInScopeTyVars                      `thenNF_Tc` \ in_scope_tvs ->
 482         zonkTcTyVars in_scope_tvs               `thenNF_Tc` \ in_scope_tys ->
 483         let
 484             in_scope_assoc = [ (zonked_tv, in_scope_tv)
 485                              | (z_ty, in_scope_tv) <- in_scope_tys `zip` in_scope_tvs,
 486                                Just zonked_tv <- [getTyVar_maybe z_ty]
 487                              ]
 488             in_scope_env = mkVarEnv in_scope_assoc
 489         in
 490
 491         -- "check" checks each sig tyvar in turn
 492         foldlNF_Tc check
 493                    (env2, in_scope_env, [])
 494                    (tidy_tvs `zip` tidy_tys)    `thenNF_Tc` \ (env3, _, msgs) ->
 495
 496         failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
 497       where
 498         (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars
 499         (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
 500
 501         main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
 502
 503         check (env, acc, msgs) (sig_tyvar,ty)
 504                 -- sig_tyvar is from the signature;
 505                 -- ty is what you get if you zonk sig_tyvar and then tidy it
 506                 --
 507                 -- acc maps a zonked type variable back to a signature type variable
 508           = case getTyVar_maybe ty of {
 509               Nothing ->                        -- Error (a)!
 510                         returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
 511
 512               Just tv ->
 513
 514             case lookupVarEnv acc tv of {
 515                 Just sig_tyvar' ->      -- Error (b) or (d)!
 516                         returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
 517
 518                 Nothing ->
 519
 520             if tv `elemVarSet` globals  -- Error (c)! Type variable escapes
 521                                         -- The least comprehensible, so put it last
 522             then   tcGetValueEnv                        `thenNF_Tc` \ ve ->
 523                    find_globals tv env (eltsUFM ve)     `thenNF_Tc` \ (env1, globs) ->
 524                    returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
 525
 526             else        -- All OK
 527             returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
 528             }}
 529
 530 -- find_globals looks at the value environment and finds values
 531 -- whose types mention the offending type variable.  It has to be
 532 -- careful to zonk the Id's type first, so it has to be in the monad.
 533 -- We must be careful to pass it a zonked type variable, too.
 534 find_globals tv tidy_env ids
 535   | null ids
 536   = returnNF_Tc (tidy_env, [])
 537
 538 find_globals tv tidy_env (id:ids)
 539   | not (isLocallyDefined id) ||
 540     isEmptyVarSet (idFreeTyVars id)
 541   = find_globals tv tidy_env ids
 542
 543   | otherwise
 544   = zonkTcType (idType id)      `thenNF_Tc` \ id_ty ->
 545     if tv `elemVarSet` tyVarsOfType id_ty then
 546         let
 547            (tidy_env', id_ty') = tidyOpenType tidy_env id_ty
 548         in
 549         find_globals tv tidy_env' ids   `thenNF_Tc` \ (tidy_env'', globs) ->
 550         returnNF_Tc (tidy_env'', (idName id, id_ty') : globs)
 551     else
 552         find_globals tv tidy_env ids
 553
 554 escape_msg sig_tv tv globs
 555   = vcat [mk_msg sig_tv <+> ptext SLIT("escapes"),
 556           pp_escape,
 557           ptext SLIT("The following variables in the environment mention") <+> quotes (ppr tv),
 558           nest 4 (vcat_first 10 [ppr name <+> dcolon <+> ppr ty | (name,ty) <- globs])
 559     ]
 560   where
 561     pp_escape | sig_tv /= tv = ptext SLIT("It unifies with") <+>
 562                                quotes (ppr tv) <> comma <+>
 563                                ptext SLIT("which is mentioned in the environment")
 564               | otherwise    = ptext SLIT("It is mentioned in the environment")
 565
 566     vcat_first :: Int -> [SDoc] -> SDoc
 567     vcat_first n []     = empty
 568     vcat_first 0 (x:xs) = text "...others omitted..."
 569     vcat_first n (x:xs) = x $$ vcat_first (n-1) xs
 570
 571 unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing
 572 mk_msg tv          = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
 573 \end{code}
 574
 575 These two context are used with checkSigTyVars
 576
 577 \begin{code}
 578 sigCtxt :: (Type -> Message) -> Type
 579         -> TidyEnv -> NF_TcM s (TidyEnv, Message)
 580 sigCtxt mk_msg sig_ty tidy_env
 581   = let
 582         (env1, tidy_sig_ty) = tidyOpenType tidy_env sig_ty
 583     in
 584     returnNF_Tc (env1, mk_msg tidy_sig_ty)
 585
 586 sigPatCtxt bound_tvs bound_ids tidy_env
 587   = returnNF_Tc (env1,
 588                  sep [ptext SLIT("When checking a pattern that binds"),
 589                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))])
 590   where
 591     show_ids = filter is_interesting bound_ids
 592     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 593
 594     (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 595     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 596         -- Don't zonk the types so we get the separate, un-unified versions
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection{Errors and contexts}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 \begin{code}
 607 naughtyCCallContextErr clas_name
 608   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas_name),
 609          ptext SLIT("in a context")]
 610
 611 typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
 612
 613 typeKindCtxt :: RenamedHsType -> Message
 614 typeKindCtxt ty = sep [ptext SLIT("When checking that"),
 615                        nest 2 (quotes (ppr ty)),
 616                        ptext SLIT("is a type")]
 617
 618 appKindCtxt :: SDoc -> Message
 619 appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
 620
 621 classAsTyConErr name
 622   = ptext SLIT("Class used as a type constructor:") <+> ppr name
 623
 624 tyConAsClassErr name
 625   = ptext SLIT("Type constructor used as a class:") <+> ppr name
 626
 627 tyVarAsClassErr name
 628   = ptext SLIT("Type variable used as a class:") <+> ppr name
 629 \end{code}