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 ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
   8                     UserTypeCtxt(..),
   9
  10                         -- Kind checking
  11                     kcHsTyVar, kcHsTyVars, mkTyClTyVars,
  12                     kcHsType, kcHsSigType, kcHsSigTypes,
  13                     kcHsLiftedSigType, kcHsContext,
  14                     tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars,
  15
  16                     TcSigInfo(..), tcTySig, mkTcSig, maybeSig
  17                   ) where
  18
  19 #include "HsVersions.h"
  20
  21 import HsSyn            ( HsType(..), HsTyVarBndr(..),
  22                           Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
  23 import RnHsSyn          ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
  24 import TcHsSyn          ( TcId )
  25
  26 import TcMonad
  27 import TcEnv            ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
  28                           tcInLocalScope,
  29                           TyThing(..), TcTyThing(..), tcExtendKindEnv
  30                         )
  31 import TcMType          ( newKindVar, zonkKindEnv, tcInstSigType,
  32                           checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
  33                         )
  34 import TcUnify          ( unifyKind, unifyOpenTypeKind )
  35 import TcType           ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
  36                           TcTyVar, TcKind, TcThetaType, TcTauType,
  37                           mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
  38                           tcSplitForAllTys, tcSplitRhoTy,
  39                           hoistForAllTys, zipFunTys,
  40                           mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys,
  41                           liftedTypeKind, unliftedTypeKind, mkArrowKind,
  42                           mkArrowKinds, tcSplitFunTy_maybe
  43                         )
  44 import Inst             ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
  45
  46 import Subst            ( mkTopTyVarSubst, substTy )
  47 import Id               ( mkLocalId, idName, idType )
  48 import Var              ( TyVar, mkTyVar, tyVarKind )
  49 import ErrUtils         ( Message )
  50 import TyCon            ( TyCon, isSynTyCon, tyConKind )
  51 import Class            ( classTyCon )
  52 import Name             ( Name )
  53 import NameSet
  54 import TysWiredIn       ( mkListTy, mkTupleTy, genUnitTyCon )
  55 import BasicTypes       ( Boxity(..) )
  56 import SrcLoc           ( SrcLoc )
  57 import Util             ( lengthIs )
  58 import Outputable
  59
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{Checking types}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 Generally speaking we now type-check types in three phases
  70
  71         1.  Kind check the HsType [kcHsType]
  72         2.  Convert from HsType to Type, and hoist the foralls [tcHsType]
  73         3.  Check the validity of the resulting type [checkValidType]
  74
  75 Often these steps are done one after the othe (tcHsSigType).
  76 But in mutually recursive groups of type and class decls we do
  77         1 kind-check the whole group
  78         2 build TyCons/Classes in a knot-tied wa
  79         3 check the validity of types in the now-unknotted TyCons/Classes
  80
  81 \begin{code}
  82 tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type
  83   -- Do kind checking, and hoist for-alls to the top
  84 tcHsSigType ctxt ty = tcAddErrCtxt (checkTypeCtxt ctxt ty) (
  85                         kcTypeType ty           `thenTc_`
  86                         tcHsType ty
  87                       )                         `thenTc` \ ty' ->
  88                       checkValidType ctxt ty'   `thenTc_`
  89                       returnTc ty'
  90
  91 checkTypeCtxt ctxt ty
  92   = vcat [ptext SLIT("In the type:") <+> ppr ty,
  93           ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
  94
  95 tcHsType    :: RenamedHsType -> TcM Type
  96   -- Don't do kind checking, nor validity checking,
  97   --    but do hoist for-alls to the top
  98   -- This is used in type and class decls, where kinding is
  99   -- done in advance, and validity checking is done later
 100   -- [Validity checking done later because of knot-tying issues.]
 101 tcHsType ty = tc_type ty  `thenTc` \ ty' ->
 102               returnTc (hoistForAllTys ty')
 103
 104 tcHsTheta :: RenamedContext -> TcM ThetaType
 105 -- Used when we are expecting a ClassContext (i.e. no implicit params)
 106 -- Does not do validity checking, like tcHsType
 107 tcHsTheta hs_theta = mapTc tc_pred hs_theta
 108
 109 -- In interface files the type is already kinded,
 110 -- and we definitely don't want to hoist for-alls.
 111 -- Otherwise we'll change
 112 --      dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a
 113 -- into
 114 --      dmfail :: forall m:(*->*) a:* Monad m => String -> m a
 115 -- which definitely isn't right!
 116 tcIfaceType ty = tc_type ty
 117 \end{code}
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection{Kind checking}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 Kind checking
 127 ~~~~~~~~~~~~~
 128 When we come across the binding site for some type variables, we
 129 proceed in two stages
 130
 131 1. Figure out what kind each tyvar has
 132
 133 2. Create suitably-kinded tyvars,
 134    extend the envt,
 135    and typecheck the body
 136
 137 To do step 1, we proceed thus:
 138
 139 1a. Bind each type variable to a kind variable
 140 1b. Apply the kind checker
 141 1c. Zonk the resulting kinds
 142
 143 The kind checker is passed to tcHsTyVars as an argument.
 144
 145 For example, when we find
 146         (forall a m. m a -> m a)
 147 we bind a,m to kind varibles and kind-check (m a -> m a).  This
 148 makes a get kind *, and m get kind *->*.  Now we typecheck (m a -> m a)
 149 in an environment that binds a and m suitably.
 150
 151 The kind checker passed to tcHsTyVars needs to look at enough to
 152 establish the kind of the tyvar:
 153   * For a group of type and class decls, it's just the group, not
 154         the rest of the program
 155   * For a tyvar bound in a pattern type signature, its the types
 156         mentioned in the other type signatures in that bunch of patterns
 157   * For a tyvar bound in a RULE, it's the type signatures on other
 158         universally quantified variables in the rule
 159
 160 Note that this may occasionally give surprising results.  For example:
 161
 162         data T a b = MkT (a b)
 163
 164 Here we deduce                  a::*->*, b::*.
 165 But equally valid would be
 166                                 a::(*->*)-> *, b::*->*
 167
 168 \begin{code}
 169 -- tcHsTyVars is used for type variables in type signatures
 170 --      e.g. forall a. a->a
 171 -- They are immutable, because they scope only over the signature
 172 -- They may or may not be explicitly-kinded
 173 tcHsTyVars :: [HsTyVarBndr Name]
 174            -> TcM a                             -- The kind checker
 175            -> ([TyVar] -> TcM b)
 176            -> TcM b
 177
 178 tcHsTyVars [] kind_check thing_inside = thing_inside []
 179         -- A useful short cut for a common case!
 180
 181 tcHsTyVars tv_names kind_check thing_inside
 182   = kcHsTyVars tv_names                                 `thenNF_Tc` \ tv_names_w_kinds ->
 183     tcExtendKindEnv tv_names_w_kinds kind_check         `thenTc_`
 184     zonkKindEnv tv_names_w_kinds                        `thenNF_Tc` \ tvs_w_kinds ->
 185     let
 186         tyvars = mkImmutTyVars tvs_w_kinds
 187     in
 188     tcExtendTyVarEnv tyvars (thing_inside tyvars)
 189
 190
 191
 192 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
 193 -- tcAddScopedTyVars is used for scoped type variables
 194 -- added by pattern type signatures
 195 --      e.g.  \ (x::a) (y::a) -> x+y
 196 -- They never have explicit kinds (because this is source-code only)
 197 -- They are mutable (because they can get bound to a more specific type)
 198
 199 -- Find the not-already-in-scope signature type variables,
 200 -- kind-check them, and bring them into scope
 201 --
 202 -- We no longer specify that these type variables must be univerally
 203 -- quantified (lots of email on the subject).  If you want to put that
 204 -- back in, you need to
 205 --      a) Do a checkSigTyVars after thing_inside
 206 --      b) More insidiously, don't pass in expected_ty, else
 207 --         we unify with it too early and checkSigTyVars barfs
 208 --         Instead you have to pass in a fresh ty var, and unify
 209 --         it with expected_ty afterwards
 210 tcAddScopedTyVars [] thing_inside
 211   = thing_inside        -- Quick get-out for the empty case
 212
 213 tcAddScopedTyVars sig_tys thing_inside
 214   = tcGetEnv                                    `thenNF_Tc` \ env ->
 215     let
 216         all_sig_tvs     = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
 217         sig_tvs         = filter not_in_scope (nameSetToList all_sig_tvs)
 218         not_in_scope tv = not (tcInLocalScope env tv)
 219     in
 220     mapNF_Tc newNamedKindVar sig_tvs                    `thenTc` \ kind_env ->
 221     tcExtendKindEnv kind_env (kcHsSigTypes sig_tys)     `thenTc_`
 222     zonkKindEnv kind_env                                `thenNF_Tc` \ tvs_w_kinds ->
 223     listTc [ tcNewMutTyVar name kind PatSigTv
 224            | (name, kind) <- tvs_w_kinds]               `thenNF_Tc` \ tyvars ->
 225     tcExtendTyVarEnv tyvars thing_inside
 226 \end{code}
 227
 228
 229 \begin{code}
 230 kcHsTyVar  :: HsTyVarBndr name   -> NF_TcM (name, TcKind)
 231 kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM [(name, TcKind)]
 232
 233 kcHsTyVar (UserTyVar name)       = newNamedKindVar name
 234 kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
 235
 236 kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
 237
 238 newNamedKindVar name = newKindVar       `thenNF_Tc` \ kind ->
 239                        returnNF_Tc (name, kind)
 240
 241 ---------------------------
 242 kcLiftedType :: RenamedHsType -> TcM ()
 243         -- The type ty must be a *lifted* *type*
 244 kcLiftedType ty
 245   = kcHsType ty                         `thenTc` \ kind ->
 246     tcAddErrCtxt (typeKindCtxt ty)      $
 247     unifyKind liftedTypeKind kind
 248
 249 ---------------------------
 250 kcTypeType :: RenamedHsType -> TcM ()
 251         -- The type ty must be a *type*, but it can be lifted or unlifted.
 252 kcTypeType ty
 253   = kcHsType ty                         `thenTc` \ kind ->
 254     tcAddErrCtxt (typeKindCtxt ty)      $
 255     unifyOpenTypeKind kind
 256
 257 ---------------------------
 258 kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM ()
 259         -- Used for type signatures
 260 kcHsSigType       = kcTypeType
 261 kcHsSigTypes tys  = mapTc_ kcHsSigType tys
 262 kcHsLiftedSigType = kcLiftedType
 263
 264 ---------------------------
 265 kcHsType :: RenamedHsType -> TcM TcKind
 266 kcHsType (HsTyVar name)       = kcTyVar name
 267
 268 kcHsType (HsListTy ty)
 269   = kcLiftedType ty             `thenTc` \ tau_ty ->
 270     returnTc liftedTypeKind
 271
 272 kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
 273   = mapTc kcTypeType tys        `thenTc_`
 274     returnTc (case boxity of
 275                   Boxed   -> liftedTypeKind
 276                   Unboxed -> unliftedTypeKind)
 277
 278 kcHsType (HsFunTy ty1 ty2)
 279   = kcTypeType ty1      `thenTc_`
 280     kcTypeType ty2      `thenTc_`
 281     returnTc liftedTypeKind
 282
 283 kcHsType (HsNumTy _)            -- The unit type for generics
 284   = returnTc liftedTypeKind
 285
 286 kcHsType ty@(HsOpTy ty1 op ty2)
 287   = kcTyVar op                          `thenTc` \ op_kind ->
 288     kcHsType ty1                        `thenTc` \ ty1_kind ->
 289     kcHsType ty2                        `thenTc` \ ty2_kind ->
 290     tcAddErrCtxt (appKindCtxt (ppr ty)) $
 291     kcAppKind op_kind  ty1_kind         `thenTc` \ op_kind' ->
 292     kcAppKind op_kind' ty2_kind
 293
 294 kcHsType (HsPredTy pred)
 295   = kcHsPred pred               `thenTc_`
 296     returnTc liftedTypeKind
 297
 298 kcHsType ty@(HsAppTy ty1 ty2)
 299   = kcHsType ty1                        `thenTc` \ tc_kind ->
 300     kcHsType ty2                        `thenTc` \ arg_kind ->
 301     tcAddErrCtxt (appKindCtxt (ppr ty)) $
 302     kcAppKind tc_kind arg_kind
 303
 304 kcHsType (HsForAllTy (Just tv_names) context ty)
 305   = kcHsTyVars tv_names         `thenNF_Tc` \ kind_env ->
 306     tcExtendKindEnv kind_env    $
 307     kcHsContext context         `thenTc_`
 308     kcHsType ty                 `thenTc_`
 309     returnTc liftedTypeKind
 310
 311 ---------------------------
 312 kcAppKind fun_kind arg_kind
 313   = case tcSplitFunTy_maybe fun_kind of
 314         Just (arg_kind', res_kind)
 315                 -> unifyKind arg_kind arg_kind' `thenTc_`
 316                    returnTc res_kind
 317
 318         Nothing -> newKindVar                                           `thenNF_Tc` \ res_kind ->
 319                    unifyKind fun_kind (mkArrowKind arg_kind res_kind)   `thenTc_`
 320                    returnTc res_kind
 321
 322
 323 ---------------------------
 324 kc_pred :: RenamedHsPred -> TcM TcKind  -- Does *not* check for a saturated
 325                                         -- application (reason: used from TcDeriv)
 326 kc_pred pred@(HsIParam name ty)
 327   = kcHsType ty
 328
 329 kc_pred pred@(HsClassP cls tys)
 330   = kcClass cls                         `thenTc` \ kind ->
 331     mapTc kcHsType tys                  `thenTc` \ arg_kinds ->
 332     newKindVar                          `thenNF_Tc` \ kv ->
 333     unifyKind kind (mkArrowKinds arg_kinds kv)  `thenTc_`
 334     returnTc kv
 335
 336 ---------------------------
 337 kcHsContext ctxt = mapTc_ kcHsPred ctxt
 338
 339 kcHsPred pred           -- Checks that the result is of kind liftedType
 340   = tcAddErrCtxt (appKindCtxt (ppr pred))       $
 341     kc_pred pred                                `thenTc` \ kind ->
 342     unifyKind liftedTypeKind kind               `thenTc_`
 343     returnTc ()
 344
 345
 346  ---------------------------
 347 kcTyVar name    -- Could be a tyvar or a tycon
 348   = tcLookup name       `thenTc` \ thing ->
 349     case thing of
 350         AThing kind         -> returnTc kind
 351         ATyVar tv           -> returnTc (tyVarKind tv)
 352         AGlobal (ATyCon tc) -> returnTc (tyConKind tc)
 353         other               -> failWithTc (wrongThingErr "type" thing name)
 354
 355 kcClass cls     -- Must be a class
 356   = tcLookup cls                                `thenNF_Tc` \ thing ->
 357     case thing of
 358         AThing kind           -> returnTc kind
 359         AGlobal (AClass cls)  -> returnTc (tyConKind (classTyCon cls))
 360         other                 -> failWithTc (wrongThingErr "class" thing cls)
 361 \end{code}
 362
 363 %************************************************************************
 364 %*                                                                      *
 365 \subsection{tc_type}
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 tc_type, the main work horse
 370 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 371
 372         -------------------
 373         *** BIG WARNING ***
 374         -------------------
 375
 376 tc_type is used to typecheck the types in the RHS of data
 377 constructors.  In the case of recursive data types, that means that
 378 the type constructors themselves are (partly) black holes.  e.g.
 379
 380         data T a = MkT a [T a]
 381
 382 While typechecking the [T a] on the RHS, T itself is not yet fully
 383 defined.  That in turn places restrictions on what you can check in
 384 tcHsType; if you poke on too much you get a black hole.  I keep
 385 forgetting this, hence this warning!
 386
 387 So tc_type does no validity-checking.  Instead that's all done
 388 by TcMType.checkValidType
 389
 390         --------------------------
 391         *** END OF BIG WARNING ***
 392         --------------------------
 393
 394
 395 \begin{code}
 396 tc_type :: RenamedHsType -> TcM Type
 397
 398 tc_type ty@(HsTyVar name)
 399   = tc_app ty []
 400
 401 tc_type (HsListTy ty)
 402   = tc_type ty  `thenTc` \ tau_ty ->
 403     returnTc (mkListTy tau_ty)
 404
 405 tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
 406   = ASSERT( tys `lengthIs` arity )
 407     tc_types tys        `thenTc` \ tau_tys ->
 408     returnTc (mkTupleTy boxity arity tau_tys)
 409
 410 tc_type (HsFunTy ty1 ty2)
 411   = tc_type ty1                 `thenTc` \ tau_ty1 ->
 412     tc_type ty2                 `thenTc` \ tau_ty2 ->
 413     returnTc (mkFunTy tau_ty1 tau_ty2)
 414
 415 tc_type (HsNumTy n)
 416   = ASSERT(n== 1)
 417     returnTc (mkTyConApp genUnitTyCon [])
 418
 419 tc_type (HsOpTy ty1 op ty2)
 420   = tc_type ty1 `thenTc` \ tau_ty1 ->
 421     tc_type ty2 `thenTc` \ tau_ty2 ->
 422     tc_fun_type op [tau_ty1,tau_ty2]
 423
 424 tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
 425
 426 tc_type (HsPredTy pred)
 427   = tc_pred pred        `thenTc` \ pred' ->
 428     returnTc (mkPredTy pred')
 429
 430 tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty)
 431   = let
 432         kind_check = kcHsContext ctxt `thenTc_` kcHsType ty
 433     in
 434     tcHsTyVars tv_names kind_check      $ \ tyvars ->
 435     mapTc tc_pred ctxt                  `thenTc` \ theta ->
 436     tc_type ty                          `thenTc` \ tau ->
 437     returnTc (mkSigmaTy tyvars theta tau)
 438
 439 tc_types arg_tys = mapTc tc_type arg_tys
 440 \end{code}
 441
 442 Help functions for type applications
 443 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 444
 445 \begin{code}
 446 tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type
 447 tc_app (HsAppTy ty1 ty2) tys
 448   = tc_app ty1 (ty2:tys)
 449
 450 tc_app ty tys
 451   = tcAddErrCtxt (appKindCtxt pp_app)   $
 452     tc_types tys                        `thenTc` \ arg_tys ->
 453     case ty of
 454         HsTyVar fun -> tc_fun_type fun arg_tys
 455         other       -> tc_type ty               `thenTc` \ fun_ty ->
 456                        returnNF_Tc (mkAppTys fun_ty arg_tys)
 457   where
 458     pp_app = ppr ty <+> sep (map pprParendHsType tys)
 459
 460 -- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
 461 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
 462 --      hence the rather strange functionality.
 463
 464 tc_fun_type name arg_tys
 465   = tcLookup name                       `thenTc` \ thing ->
 466     case thing of
 467         ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 468
 469         AGlobal (ATyCon tc)
 470                 | isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
 471                 | otherwise     ->  returnTc (mkTyConApp tc arg_tys)
 472
 473         other -> failWithTc (wrongThingErr "type constructor" thing name)
 474 \end{code}
 475
 476
 477 Contexts
 478 ~~~~~~~~
 479 \begin{code}
 480 tcHsPred pred = kc_pred pred `thenTc_`  tc_pred pred
 481         -- Is happy with a partial application, e.g. (ST s)
 482         -- Used from TcDeriv
 483
 484 tc_pred assn@(HsClassP class_name tys)
 485   = tcAddErrCtxt (appKindCtxt (ppr assn))       $
 486     tc_types tys                        `thenTc` \ arg_tys ->
 487     tcLookupGlobal class_name                   `thenTc` \ thing ->
 488     case thing of
 489         AClass clas -> returnTc (ClassP clas arg_tys)
 490         other       -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
 491
 492 tc_pred assn@(HsIParam name ty)
 493   = tcAddErrCtxt (appKindCtxt (ppr assn))       $
 494     tc_type ty                                  `thenTc` \ arg_ty ->
 495     returnTc (IParam name arg_ty)
 496 \end{code}
 497
 498
 499
 500 %************************************************************************
 501 %*                                                                      *
 502 \subsection{Type variables, with knot tying!}
 503 %*                                                                      *
 504 %************************************************************************
 505
 506 \begin{code}
 507 mkImmutTyVars :: [(Name,Kind)] -> [TyVar]
 508 mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs]
 509
 510 mkTyClTyVars :: Kind                    -- Kind of the tycon or class
 511              -> [HsTyVarBndr Name]
 512              -> [TyVar]
 513 mkTyClTyVars kind tyvar_names
 514   = mkImmutTyVars tyvars_w_kinds
 515   where
 516     (tyvars_w_kinds, _) = zipFunTys (hsTyVarNames tyvar_names) kind
 517 \end{code}
 518
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection{Signatures}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 @tcSigs@ checks the signatures for validity, and returns a list of
 527 {\em freshly-instantiated} signatures.  That is, the types are already
 528 split up, and have fresh type variables installed.  All non-type-signature
 529 "RenamedSigs" are ignored.
 530
 531 The @TcSigInfo@ contains @TcTypes@ because they are unified with
 532 the variable's type, and after that checked to see whether they've
 533 been instantiated.
 534
 535 \begin{code}
 536 data TcSigInfo
 537   = TySigInfo
 538         Name                    -- N, the Name in corresponding binding
 539
 540         TcId                    -- *Polymorphic* binder for this value...
 541                                 -- Has name = N
 542
 543         [TcTyVar]               -- tyvars
 544         TcThetaType             -- theta
 545         TcTauType               -- tau
 546
 547         TcId                    -- *Monomorphic* binder for this value
 548                                 -- Does *not* have name = N
 549                                 -- Has type tau
 550
 551         [Inst]                  -- Empty if theta is null, or
 552                                 -- (method mono_id) otherwise
 553
 554         SrcLoc                  -- Of the signature
 555
 556 instance Outputable TcSigInfo where
 557     ppr (TySigInfo nm id tyvars theta tau _ inst loc) =
 558         ppr nm <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
 559
 560 maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
 561         -- Search for a particular signature
 562 maybeSig [] name = Nothing
 563 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
 564   | name == sig_name = Just sig
 565   | otherwise        = maybeSig sigs name
 566 \end{code}
 567
 568
 569 \begin{code}
 570 tcTySig :: RenamedSig -> TcM TcSigInfo
 571
 572 tcTySig (Sig v ty src_loc)
 573  = tcAddSrcLoc src_loc                          $
 574    tcHsSigType (FunSigCtxt v) ty                `thenTc` \ sigma_tc_ty ->
 575    mkTcSig (mkLocalId v sigma_tc_ty) src_loc    `thenNF_Tc` \ sig ->
 576    returnTc sig
 577
 578 mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo
 579 mkTcSig poly_id src_loc
 580   =     -- Instantiate this type
 581         -- It's important to do this even though in the error-free case
 582         -- we could just split the sigma_tc_ty (since the tyvars don't
 583         -- unified with anything).  But in the case of an error, when
 584         -- the tyvars *do* get unified with something, we want to carry on
 585         -- typechecking the rest of the program with the function bound
 586         -- to a pristine type, namely sigma_tc_ty
 587    tcInstSigType SigTv (idType poly_id)         `thenNF_Tc` \ (tyvars', theta', tau') ->
 588
 589    newMethodWithGivenTy SignatureOrigin
 590                         poly_id
 591                         (mkTyVarTys tyvars')
 592                         theta' tau'             `thenNF_Tc` \ inst ->
 593         -- We make a Method even if it's not overloaded; no harm
 594
 595    returnNF_Tc (TySigInfo (idName poly_id) poly_id tyvars' theta' tau'
 596                           (instToId inst) [inst] src_loc)
 597 \end{code}
 598
 599
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsection{Errors and contexts}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 typeKindCtxt :: RenamedHsType -> Message
 609 typeKindCtxt ty = sep [ptext SLIT("When checking that"),
 610                        nest 2 (quotes (ppr ty)),
 611                        ptext SLIT("is a type")]
 612
 613 appKindCtxt :: SDoc -> Message
 614 appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
 615
 616 wrongThingErr expected thing name
 617   = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected
 618   where
 619     pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
 620     pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
 621     pp_thing (AGlobal (AnId   _)) = ptext SLIT("Identifier")
 622     pp_thing (ATyVar _)           = ptext SLIT("Type variable")
 623     pp_thing (ATcId _)            = ptext SLIT("Local identifier")
 624     pp_thing (AThing _)           = ptext SLIT("Utterly bogus")
 625 \end{code}