compiler/typecheck/TcEnv.lhs

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