compiler/typecheck/TcEnv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 module TcEnv(
   7         TyThing(..), TcTyThing(..), TcId,
   8
   9         -- Instance environment, and InstInfo type
  10         InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
  11         simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
  12         InstBindings(..),
  13
  14         -- Global environment
  15         tcExtendGlobalEnv,
  16         tcExtendGlobalValEnv,
  17         tcLookupLocatedGlobal,  tcLookupGlobal,
  18         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
  19         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
  20         tcLookupLocatedClass, tcLookupFamInst,
  21
  22         -- Local environment
  23         tcExtendKindEnv, tcExtendKindEnvTvs,
  24         tcExtendTyVarEnv, tcExtendTyVarEnv2,
  25         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
  26         tcLookup, tcLookupLocated, tcLookupLocalIds,
  27         tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
  28         lclEnvElts, getInLocalScope, findGlobals,
  29         wrongThingErr, pprBinders,
  30         refineEnvironment,
  31
  32         tcExtendRecEnv,         -- For knot-tying
  33
  34         -- Rules
  35         tcExtendRules,
  36
  37         -- Global type variables
  38         tcGetGlobalTyVars,
  39
  40         -- Template Haskell stuff
  41         checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
  42         topIdLvl,
  43
  44         -- New Ids
  45         newLocalName, newDFunName, newFamInstTyConName
  46   ) where
  47
  48 #include "HsVersions.h"
  49
  50 import HsSyn
  51 import TcIface
  52 import IfaceEnv
  53 import TcRnMonad
  54 import TcMType
  55 import TcType
  56 import TcGadt
  57 import qualified Type
  58 import Id
  59 import Var
  60 import VarSet
  61 import VarEnv
  62 import RdrName
  63 import InstEnv
  64 import FamInstEnv
  65 import DataCon
  66 import TyCon
  67 import Class
  68 import Name
  69 import PrelNames
  70 import NameEnv
  71 import OccName
  72 import HscTypes
  73 import SrcLoc
  74 import Outputable
  75 \end{code}
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 %*                      tcLookupGlobal                                  *
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
  85 unless you know that the SrcSpan in the monad is already set to the
  86 span of the Name.
  87
  88 \begin{code}
  89 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
  90 -- c.f. IfaceEnvEnv.tcIfaceGlobal
  91 tcLookupLocatedGlobal name
  92   = addLocM tcLookupGlobal name
  93
  94 tcLookupGlobal :: Name -> TcM TyThing
  95 -- The Name is almost always an ExternalName, but not always
  96 -- In GHCi, we may make command-line bindings (ghci> let x = True)
  97 -- that bind a GlobalId, but with an InternalName
  98 tcLookupGlobal name
  99   = do  { env <- getGblEnv
 100
 101                 -- Try local envt
 102         ; case lookupNameEnv (tcg_type_env env) name of {
 103                 Just thing -> return thing ;
 104                 Nothing    -> do
 105
 106                 -- Try global envt
 107         { (eps,hpt) <- getEpsAndHpt
 108         ; dflags <- getDOpts
 109         ; case lookupType dflags hpt (eps_PTE eps) name of  {
 110             Just thing -> return thing ;
 111             Nothing    -> do
 112
 113                 -- Should it have been in the local envt?
 114         { case nameModule_maybe name of
 115                 Nothing -> notFound name        -- Internal names can happen in GHCi
 116
 117                 Just mod | mod == tcg_mod env   -- Names from this module
 118                          -> notFound name       -- should be in tcg_type_env
 119                          | mod == thFAKE        -- Names bound in TH declaration brackets
 120                          -> notFound name       -- should be in tcg_env
 121                          | otherwise
 122                          -> tcImportDecl name   -- Go find it in an interface
 123         }}}}}
 124
 125 tcLookupField :: Name -> TcM Id         -- Returns the selector Id
 126 tcLookupField name
 127   = tcLookupGlobal name         `thenM` \ thing ->
 128     case thing of
 129         AnId id -> return id
 130         other   -> wrongThingErr "field name" (AGlobal thing) name
 131
 132 tcLookupDataCon :: Name -> TcM DataCon
 133 tcLookupDataCon name
 134   = tcLookupGlobal name `thenM` \ thing ->
 135     case thing of
 136         ADataCon con -> return con
 137         other        -> wrongThingErr "data constructor" (AGlobal thing) name
 138
 139 tcLookupClass :: Name -> TcM Class
 140 tcLookupClass name
 141   = tcLookupGlobal name         `thenM` \ thing ->
 142     case thing of
 143         AClass cls -> return cls
 144         other      -> wrongThingErr "class" (AGlobal thing) name
 145
 146 tcLookupTyCon :: Name -> TcM TyCon
 147 tcLookupTyCon name
 148   = tcLookupGlobal name         `thenM` \ thing ->
 149     case thing of
 150         ATyCon tc -> return tc
 151         other     -> wrongThingErr "type constructor" (AGlobal thing) name
 152
 153 tcLookupLocatedGlobalId :: Located Name -> TcM Id
 154 tcLookupLocatedGlobalId = addLocM tcLookupId
 155
 156 tcLookupLocatedClass :: Located Name -> TcM Class
 157 tcLookupLocatedClass = addLocM tcLookupClass
 158
 159 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
 160 tcLookupLocatedTyCon = addLocM tcLookupTyCon
 161
 162 -- Look up the representation tycon of a family instance.
 163 --
 164 tcLookupFamInst :: TyCon -> [Type] -> TcM TyCon
 165 tcLookupFamInst tycon tys
 166   = do { env <- getGblEnv
 167        ; eps <- getEps
 168        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
 169        ; case lookupFamInstEnvExact instEnv tycon tys of
 170            Nothing      -> famInstNotFound tycon tys
 171            Just famInst -> return $ famInstTyCon famInst
 172        }
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177                 Extending the global environment
 178 %*                                                                      *
 179 %************************************************************************
 180
 181
 182 \begin{code}
 183 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
 184   -- Given a mixture of Ids, TyCons, Classes, all from the
 185   -- module being compiled, extend the global environment
 186 tcExtendGlobalEnv things thing_inside
 187    = do { env <- getGblEnv
 188         ; let ge'  = extendTypeEnvList (tcg_type_env env) things
 189         ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
 190
 191 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 192   -- Same deal as tcExtendGlobalEnv, but for Ids
 193 tcExtendGlobalValEnv ids thing_inside
 194   = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
 195 \end{code}
 196
 197 \begin{code}
 198 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
 199 -- Extend the global environments for the type/class knot tying game
 200 tcExtendRecEnv gbl_stuff thing_inside
 201  = updGblEnv upd thing_inside
 202  where
 203    upd env = env { tcg_type_env = extend (tcg_type_env env) }
 204    extend env = extendNameEnvList env gbl_stuff
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection{The local environment}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 tcLookupLocated :: Located Name -> TcM TcTyThing
 216 tcLookupLocated = addLocM tcLookup
 217
 218 tcLookup :: Name -> TcM TcTyThing
 219 tcLookup name
 220   = getLclEnv           `thenM` \ local_env ->
 221     case lookupNameEnv (tcl_env local_env) name of
 222         Just thing -> returnM thing
 223         Nothing    -> tcLookupGlobal name `thenM` \ thing ->
 224                       returnM (AGlobal thing)
 225
 226 tcLookupTyVar :: Name -> TcM TcTyVar
 227 tcLookupTyVar name
 228   = tcLookup name       `thenM` \ thing ->
 229     case thing of
 230         ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
 231         other       -> pprPanic "tcLookupTyVar" (ppr name)
 232
 233 tcLookupId :: Name -> TcM Id
 234 -- Used when we aren't interested in the binding level, nor refinement.
 235 -- The "no refinement" part means that we return the un-refined Id regardless
 236 --
 237 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
 238 tcLookupId name
 239   = tcLookup name       `thenM` \ thing ->
 240     case thing of
 241         ATcId { tct_id = id} -> returnM id
 242         AGlobal (AnId id)    -> returnM id
 243         other                -> pprPanic "tcLookupId" (ppr name)
 244
 245 tcLookupLocalIds :: [Name] -> TcM [TcId]
 246 -- We expect the variables to all be bound, and all at
 247 -- the same level as the lookup.  Only used in one place...
 248 tcLookupLocalIds ns
 249   = getLclEnv           `thenM` \ env ->
 250     returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
 251   where
 252     lookup lenv lvl name
 253         = case lookupNameEnv lenv name of
 254                 Just (ATcId { tct_id = id, tct_level = lvl1 })
 255                         -> ASSERT( lvl == lvl1 ) id
 256                 other   -> pprPanic "tcLookupLocalIds" (ppr name)
 257
 258 lclEnvElts :: TcLclEnv -> [TcTyThing]
 259 lclEnvElts env = nameEnvElts (tcl_env env)
 260
 261 getInLocalScope :: TcM (Name -> Bool)
 262   -- Ids only
 263 getInLocalScope = getLclEnv     `thenM` \ env ->
 264                   let
 265                         lcl_env = tcl_env env
 266                   in
 267                   return (`elemNameEnv` lcl_env)
 268 \end{code}
 269
 270 \begin{code}
 271 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
 272 tcExtendKindEnv things thing_inside
 273   = updLclEnv upd thing_inside
 274   where
 275     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 276     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 277
 278 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
 279 tcExtendKindEnvTvs bndrs thing_inside
 280   = updLclEnv upd thing_inside
 281   where
 282     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 283     extend env  = extendNameEnvList env pairs
 284     pairs       = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
 285
 286 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 287 tcExtendTyVarEnv tvs thing_inside
 288   = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
 289
 290 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
 291 tcExtendTyVarEnv2 binds thing_inside
 292   = getLclEnv      `thenM` \ env@(TcLclEnv {tcl_env = le,
 293                                             tcl_tyvars = gtvs,
 294                                             tcl_rdr = rdr_env}) ->
 295     let
 296         rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
 297         new_tv_set = tcTyVarsOfTypes (map snd binds)
 298         le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
 299     in
 300         -- It's important to add the in-scope tyvars to the global tyvar set
 301         -- as well.  Consider
 302         --      f (_::r) = let g y = y::r in ...
 303         -- Here, g mustn't be generalised.  This is also important during
 304         -- class and instance decls, when we mustn't generalise the class tyvars
 305         -- when typechecking the methods.
 306     tc_extend_gtvs gtvs new_tv_set              `thenM` \ gtvs' ->
 307     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 308
 309 getScopedTyVarBinds :: TcM [(Name, TcType)]
 310 getScopedTyVarBinds
 311   = do  { lcl_env <- getLclEnv
 312         ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
 313 \end{code}
 314
 315
 316 \begin{code}
 317 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
 318 -- Invariant: the TcIds are fully zonked. Reasons:
 319 --      (a) The kinds of the forall'd type variables are defaulted
 320 --          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
 321 --      (b) There are no via-Indirect occurrences of the bound variables
 322 --          in the types, because instantiation does not look through such things
 323 --      (c) The call to tyVarsOfTypes is ok without looking through refs
 324 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
 325
 326 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
 327 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
 328
 329 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 330 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
 331 tcExtendIdEnv2 names_w_ids thing_inside
 332   = getLclEnv           `thenM` \ env ->
 333     let
 334         extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
 335         th_lvl              = thLevel (tcl_th_ctxt   env)
 336         extra_env           = [ (name, ATcId { tct_id = id,
 337                                                tct_level = th_lvl,
 338                                                tct_type = id_ty,
 339                                                tct_co = if isRefineableTy id_ty
 340                                                         then Just idHsWrapper
 341                                                         else Nothing })
 342                               | (name,id) <- names_w_ids, let id_ty = idType id]
 343         le'                 = extendNameEnvList (tcl_env env) extra_env
 344         rdr_env'            = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
 345     in
 346     traceTc (text "env2") `thenM_`
 347     traceTc (text "env3" <+> ppr extra_env) `thenM_`
 348     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
 349     (traceTc (text "env4") `thenM_`
 350     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
 351 \end{code}
 352
 353
 354 \begin{code}
 355 -----------------------
 356 -- findGlobals looks at the value environment and finds values
 357 -- whose types mention the offending type variable.  It has to be
 358 -- careful to zonk the Id's type first, so it has to be in the monad.
 359 -- We must be careful to pass it a zonked type variable, too.
 360
 361 findGlobals :: TcTyVarSet
 362             -> TidyEnv
 363             -> TcM (TidyEnv, [SDoc])
 364
 365 findGlobals tvs tidy_env
 366   = getLclEnv           `thenM` \ lcl_env ->
 367     go tidy_env [] (lclEnvElts lcl_env)
 368   where
 369     go tidy_env acc [] = returnM (tidy_env, acc)
 370     go tidy_env acc (thing : things)
 371       = find_thing ignore_it tidy_env thing     `thenM` \ (tidy_env1, maybe_doc) ->
 372         case maybe_doc of
 373           Just d  -> go tidy_env1 (d:acc) things
 374           Nothing -> go tidy_env1 acc     things
 375
 376     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 377
 378 -----------------------
 379 find_thing ignore_it tidy_env (ATcId { tct_id = id })
 380   = zonkTcType  (idType id)     `thenM` \ id_ty ->
 381     if ignore_it id_ty then
 382         returnM (tidy_env, Nothing)
 383     else let
 384         (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 385         msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
 386                    nest 2 (parens (ptext SLIT("bound at") <+>
 387                                    ppr (getSrcLoc id)))]
 388     in
 389     returnM (tidy_env', Just msg)
 390
 391 find_thing ignore_it tidy_env (ATyVar tv ty)
 392   = zonkTcType ty               `thenM` \ tv_ty ->
 393     if ignore_it tv_ty then
 394         returnM (tidy_env, Nothing)
 395     else let
 396         -- The name tv is scoped, so we don't need to tidy it
 397         (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 398         msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
 399
 400         eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
 401                    getOccName tv == getOccName tv' = empty
 402                  | otherwise = equals <+> ppr tidy_ty
 403                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 404         bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
 405     in
 406     returnM (tidy_env1, Just msg)
 407
 408 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 409 \end{code}
 410
 411 \begin{code}
 412 refineEnvironment :: Refinement -> TcM a -> TcM a
 413 -- I don't think I have to refine the set of global type variables in scope
 414 -- Reason: the refinement never increases that set
 415 refineEnvironment reft thing_inside
 416   | isEmptyRefinement reft              -- Common case
 417   = thing_inside
 418   | otherwise
 419   = do  { env <- getLclEnv
 420         ; let le' = mapNameEnv refine (tcl_env env)
 421         ; setLclEnv (env {tcl_env = le'}) thing_inside }
 422   where
 423     refine elt@(ATcId { tct_co = Just co, tct_type = ty })
 424         | Just (co', ty') <- refineType reft ty
 425         = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
 426     refine (ATyVar tv ty)
 427         | Just (_, ty') <- refineType reft ty
 428         = ATyVar tv ty' -- Ignore the coercion that refineType returns
 429
 430     refine elt = elt    -- Common case
 431 \end{code}
 432
 433 %************************************************************************
 434 %*                                                                      *
 435 \subsection{The global tyvars}
 436 %*                                                                      *
 437 %************************************************************************
 438
 439 \begin{code}
 440 tc_extend_gtvs gtvs extra_global_tvs
 441   = readMutVar gtvs             `thenM` \ global_tvs ->
 442     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
 443 \end{code}
 444
 445 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 446 To improve subsequent calls to the same function it writes the zonked set back into
 447 the environment.
 448
 449 \begin{code}
 450 tcGetGlobalTyVars :: TcM TcTyVarSet
 451 tcGetGlobalTyVars
 452   = getLclEnv                                   `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
 453     readMutVar gtv_var                          `thenM` \ gbl_tvs ->
 454     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenM` \ gbl_tvs' ->
 455     writeMutVar gtv_var gbl_tvs'                `thenM_`
 456     returnM gbl_tvs'
 457 \end{code}
 458
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsection{Rules}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 \begin{code}
 467 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
 468         -- Just pop the new rules into the EPS and envt resp
 469         -- All the rules come from an interface file, not soruce
 470         -- Nevertheless, some may be for this module, if we read
 471         -- its interface instead of its source code
 472 tcExtendRules lcl_rules thing_inside
 473  = do { env <- getGblEnv
 474       ; let
 475           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
 476       ; setGblEnv env' thing_inside }
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482                 Meta level
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 \begin{code}
 487 instance Outputable ThStage where
 488    ppr Comp          = text "Comp"
 489    ppr (Brack l _ _) = text "Brack" <+> int l
 490    ppr (Splice l)    = text "Splice" <+> int l
 491
 492
 493 thLevel :: ThStage -> ThLevel
 494 thLevel Comp          = topLevel
 495 thLevel (Splice l)    = l
 496 thLevel (Brack l _ _) = l
 497
 498
 499 checkWellStaged :: SDoc         -- What the stage check is for
 500                 -> ThLevel      -- Binding level
 501                 -> ThStage      -- Use stage
 502                 -> TcM ()       -- Fail if badly staged, adding an error
 503 checkWellStaged pp_thing bind_lvl use_stage
 504   | bind_lvl <= use_lvl         -- OK!
 505   = returnM ()
 506
 507   | bind_lvl == topLevel        -- GHC restriction on top level splices
 508   = failWithTc $
 509     sep [ptext SLIT("GHC stage restriction:") <+>  pp_thing,
 510          nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
 511
 512   | otherwise                   -- Badly staged
 513   = failWithTc $
 514     ptext SLIT("Stage error:") <+> pp_thing <+>
 515         hsep   [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
 516                 ptext SLIT("but used at stage") <+> ppr use_lvl]
 517   where
 518     use_lvl = thLevel use_stage
 519
 520
 521 topIdLvl :: Id -> ThLevel
 522 -- Globals may either be imported, or may be from an earlier "chunk"
 523 -- (separated by declaration splices) of this module.  The former
 524 --  *can* be used inside a top-level splice, but the latter cannot.
 525 -- Hence we give the former impLevel, but the latter topLevel
 526 -- E.g. this is bad:
 527 --      x = [| foo |]
 528 --      $( f x )
 529 -- By the time we are prcessing the $(f x), the binding for "x"
 530 -- will be in the global env, not the local one.
 531 topIdLvl id | isLocalId id = topLevel
 532             | otherwise    = impLevel
 533
 534 -- Indicates the legal transitions on bracket( [| |] ).
 535 bracketOK :: ThStage -> Maybe ThLevel
 536 bracketOK (Brack _ _ _) = Nothing       -- Bracket illegal inside a bracket
 537 bracketOK stage         = Just (thLevel stage + 1)
 538
 539 -- Indicates the legal transitions on splice($).
 540 spliceOK :: ThStage -> Maybe ThLevel
 541 spliceOK (Splice _) = Nothing   -- Splice illegal inside splice
 542 spliceOK stage      = Just (thLevel stage - 1)
 543
 544 tcMetaTy :: Name -> TcM Type
 545 -- Given the name of a Template Haskell data type,
 546 -- return the type
 547 -- E.g. given the name "Expr" return the type "Expr"
 548 tcMetaTy tc_name
 549   = tcLookupTyCon tc_name       `thenM` \ t ->
 550     returnM (mkTyConApp t [])
 551 \end{code}
 552
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection{The InstInfo type}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 The InstInfo type summarises the information in an instance declaration
 561
 562     instance c => k (t tvs) where b
 563
 564 It is used just for *local* instance decls (not ones from interface files).
 565 But local instance decls includes
 566         - derived ones
 567         - generic ones
 568 as well as explicit user written ones.
 569
 570 \begin{code}
 571 data InstInfo
 572   = InstInfo {
 573       iSpec  :: Instance,               -- Includes the dfun id.  Its forall'd type
 574       iBinds :: InstBindings            -- variables scope over the stuff in InstBindings!
 575     }
 576
 577 iDFunId :: InstInfo -> DFunId
 578 iDFunId info = instanceDFunId (iSpec info)
 579
 580 data InstBindings
 581   = VanillaInst                 -- The normal case
 582         (LHsBinds Name)         -- Bindings
 583         [LSig Name]             -- User pragmas recorded for generating
 584                                 -- specialised instances
 585
 586   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 587                                 -- witness dictionary is identical to the argument
 588                                 -- dictionary.  Hence no bindings, no pragmas.
 589         (Maybe [PredType])
 590                 -- Nothing      => The newtype-derived instance involves type variables,
 591                 --                 and the dfun has a type like df :: forall a. Eq a => Eq (T a)
 592                 -- Just (r:scs) => The newtype-defined instance has no type variables
 593                 --                 so the dfun is just a constant, df :: Eq T
 594                 --                 In this case we need to know waht the rep dict, r, and the
 595                 --                 superclasses, scs, are.  (In the Nothing case these are in the
 596                 --                 dict fun's type.)
 597                 --                 Invariant: these PredTypes have no free variables
 598                 -- NB: In both cases, the representation dict is the *first* dict.
 599
 600 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
 601
 602 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
 603   where
 604     details (VanillaInst b _)  = pprLHsBinds b
 605     details (NewTypeDerived _) = text "Derived from the representation type"
 606
 607 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
 608 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
 609                           (_, _, cls, [ty]) -> (cls, ty)
 610
 611 simpleInstInfoTy :: InstInfo -> Type
 612 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
 613
 614 simpleInstInfoTyCon :: InstInfo -> TyCon
 615   -- Gets the type constructor for a simple instance declaration,
 616   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 617 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 618 \end{code}
 619
 620 Make a name for the dict fun for an instance decl.  It's an *external*
 621 name, like otber top-level names, and hence must be made with newGlobalBinder.
 622
 623 \begin{code}
 624 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
 625 newDFunName clas (ty:_) loc
 626   = do  { index   <- nextDFunIndex
 627         ; is_boot <- tcIsHsBoot
 628         ; mod     <- getModule
 629         ; let info_string = occNameString (getOccName clas) ++
 630                             occNameString (getDFunTyKey ty)
 631               dfun_occ = mkDFunOcc info_string is_boot index
 632
 633         ; newGlobalBinder mod dfun_occ loc }
 634
 635 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 636 \end{code}
 637
 638 Make a name for the representation tycon of a data/newtype instance.  It's an
 639 *external* name, like otber top-level names, and hence must be made with
 640 newGlobalBinder.
 641
 642 \begin{code}
 643 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
 644 newFamInstTyConName tc_name loc
 645   = do  { index <- nextDFunIndex
 646         ; mod   <- getModule
 647         ; let occ = nameOccName tc_name
 648         ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
 649 \end{code}
 650
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsection{Errors}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658 \begin{code}
 659 pprBinders :: [Name] -> SDoc
 660 -- Used in error messages
 661 -- Use quotes for a single one; they look a bit "busy" for several
 662 pprBinders [bndr] = quotes (ppr bndr)
 663 pprBinders bndrs  = pprWithCommas ppr bndrs
 664
 665 notFound name
 666   = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
 667                 ptext SLIT("is not in scope"))
 668
 669 wrongThingErr expected thing name
 670   = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
 671                 ptext SLIT("used as a") <+> text expected)
 672
 673 famInstNotFound tycon tys
 674   = failWithTc (quotes famInst <+> ptext SLIT("is not in scope"))
 675   where
 676     famInst = ppr tycon <+> hsep (map pprParendType tys)
 677 \end{code}