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