ghc/compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
   5
   6 \begin{code}
   7 module Inst (
   8         LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
   9         plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
  10
  11         Inst,
  12         pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
  13
  14         newDictsFromOld, newDicts, cloneDict,
  15         newMethod, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc,
  16         newOverloadedLit, newIPDict,
  17         tcInstCall, tcInstDataCon, tcSyntaxName,
  18
  19         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  20         ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
  21         instLoc, getDictClassTys, dictPred,
  22
  23         lookupInst, lookupSimpleInst, LookupInstResult(..),
  24
  25         isDict, isClassDict, isMethod,
  26         isLinearInst, linearInstType,
  27         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  28         instBindingRequired, instCanBeGeneralised,
  29
  30         zonkInst, zonkInsts,
  31         instToId, instName,
  32
  33         InstOrigin(..), InstLoc, pprInstLoc
  34     ) where
  35
  36 #include "HsVersions.h"
  37
  38 import {-# SOURCE #-}   TcExpr( tcExpr )
  39
  40 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  41 import TcHsSyn  ( TcExpr, TcId, TypecheckedHsExpr,
  42                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  43                 )
  44 import TcMonad
  45 import TcEnv    ( TcIdSet, tcGetInstEnv, tcLookupId, tcLookupGlobalId, tcLookupTyCon )
  46 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  47 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
  48                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  49                 )
  50 import TcType   ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
  51                   SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
  52                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  53                   tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
  54                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  55                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  56                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  57                   isClassPred, isTyVarClassPred, isLinearPred,
  58                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  59                   tidyType, tidyTypes, tidyFreeTyVars,
  60                   tcCmpType, tcCmpTypes, tcCmpPred, tcSplitSigmaTy
  61                 )
  62 import CoreFVs  ( idFreeTyVars )
  63 import Class    ( Class )
  64 import DataCon  ( dataConSig )
  65 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  66 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  67 import Name     ( Name, mkMethodOcc, getOccName )
  68 import PprType  ( pprPred, pprParendType )
  69 import Subst    ( emptyInScopeSet, mkSubst,
  70                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
  71                 )
  72 import Literal  ( inIntRange )
  73 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  74 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  75 import TysWiredIn ( floatDataCon, doubleDataCon )
  76 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
  77 import Util     ( thenCmp, equalLength )
  78 import BasicTypes( IPName(..), mapIPName, ipNameName )
  79
  80 import Bag
  81 import Outputable
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection[Inst-collections]{LIE: a collection of Insts}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 type LIE = Bag Inst
  92
  93 isEmptyLIE        = isEmptyBag
  94 emptyLIE          = emptyBag
  95 unitLIE inst      = unitBag inst
  96 mkLIE insts       = listToBag insts
  97 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  98 consLIE inst lie  = inst `consBag` lie
  99 plusLIEs lies     = unionManyBags lies
 100 lieToList         = bagToList
 101 listToLIE         = listToBag
 102
 103 zonkLIE :: LIE -> NF_TcM LIE
 104 zonkLIE lie = mapBagNF_Tc zonkInst lie
 105
 106 pprInsts :: [Inst] -> SDoc
 107 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 108
 109
 110 pprInstsInFull insts
 111   = vcat (map go insts)
 112   where
 113     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 114 \end{code}
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsection[Inst-types]{@Inst@ types}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 An @Inst@ is either a dictionary, an instance of an overloaded
 123 literal, or an instance of an overloaded value.  We call the latter a
 124 ``method'' even though it may not correspond to a class operation.
 125 For example, we might have an instance of the @double@ function at
 126 type Int, represented by
 127
 128         Method 34 doubleId [Int] origin
 129
 130 \begin{code}
 131 data Inst
 132   = Dict
 133         Id
 134         TcPredType
 135         InstLoc
 136
 137   | Method
 138         Id
 139
 140         TcId    -- The overloaded function
 141                         -- This function will be a global, local, or ClassOpId;
 142                         --   inside instance decls (only) it can also be an InstId!
 143                         -- The id needn't be completely polymorphic.
 144                         -- You'll probably find its name (for documentation purposes)
 145                         --        inside the InstOrigin
 146
 147         [TcType]        -- The types to which its polymorphic tyvars
 148                         --      should be instantiated.
 149                         -- These types must saturate the Id's foralls.
 150
 151         TcThetaType     -- The (types of the) dictionaries to which the function
 152                         -- must be applied to get the method
 153
 154         TcTauType       -- The type of the method
 155
 156         InstLoc
 157
 158         -- INVARIANT: in (Method u f tys theta tau loc)
 159         --      type of (f tys dicts(from theta)) = tau
 160
 161   | LitInst
 162         Id
 163         HsOverLit       -- The literal from the occurrence site
 164                         --      INVARIANT: never a rebindable-syntax literal
 165                         --      Reason: tcSyntaxName does unification, and we
 166                         --              don't want to deal with that during tcSimplify
 167         TcType          -- The type at which the literal is used
 168         InstLoc
 169 \end{code}
 170
 171 Ordering
 172 ~~~~~~~~
 173 @Insts@ are ordered by their class/type info, rather than by their
 174 unique.  This allows the context-reduction mechanism to use standard finite
 175 maps to do their stuff.
 176
 177 \begin{code}
 178 instance Ord Inst where
 179   compare = cmpInst
 180
 181 instance Eq Inst where
 182   (==) i1 i2 = case i1 `cmpInst` i2 of
 183                  EQ    -> True
 184                  other -> False
 185
 186 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = pred1 `tcCmpPred` pred2
 187 cmpInst (Dict _ _ _)              other                     = LT
 188
 189 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 190 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
 191 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 192
 193 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
 194 cmpInst (LitInst _ _ _ _)         other                     = GT
 195
 196 -- and they can only have HsInt or HsFracs in them.
 197 \end{code}
 198
 199
 200 Selection
 201 ~~~~~~~~~
 202 \begin{code}
 203 instName :: Inst -> Name
 204 instName inst = idName (instToId inst)
 205
 206 instToId :: Inst -> TcId
 207 instToId (Dict id _ _)         = id
 208 instToId (Method id _ _ _ _ _) = id
 209 instToId (LitInst id _ _ _)    = id
 210
 211 instLoc (Dict _ _         loc) = loc
 212 instLoc (Method _ _ _ _ _ loc) = loc
 213 instLoc (LitInst _ _ _    loc) = loc
 214
 215 dictPred (Dict _ pred _ ) = pred
 216 dictPred inst             = pprPanic "dictPred" (ppr inst)
 217
 218 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 219
 220 predsOfInsts :: [Inst] -> [PredType]
 221 predsOfInsts insts = concatMap predsOfInst insts
 222
 223 predsOfInst (Dict _ pred _)          = [pred]
 224 predsOfInst (Method _ _ _ theta _ _) = theta
 225 predsOfInst (LitInst _ _ _ _)        = []
 226         -- The last case is is really a big cheat
 227         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 228         -- But Num and Fractional have only one parameter and no functional
 229         -- dependencies, so I think no caller of predsOfInst will care.
 230
 231 ipNamesOfInsts :: [Inst] -> [Name]
 232 ipNamesOfInst  :: Inst   -> [Name]
 233 -- Get the implicit parameters mentioned by these Insts
 234 -- NB: ?x and %x get different Names
 235
 236 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 237
 238 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 239 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 240 ipNamesOfInst other                    = []
 241
 242 tyVarsOfInst :: Inst -> TcTyVarSet
 243 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 244 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 245 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 246                                          -- The id might have free type variables; in the case of
 247                                          -- locally-overloaded class methods, for example
 248
 249 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 250 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 251 \end{code}
 252
 253 Predicates
 254 ~~~~~~~~~~
 255 \begin{code}
 256 isDict :: Inst -> Bool
 257 isDict (Dict _ _ _) = True
 258 isDict other        = False
 259
 260 isClassDict :: Inst -> Bool
 261 isClassDict (Dict _ pred _) = isClassPred pred
 262 isClassDict other           = False
 263
 264 isTyVarDict :: Inst -> Bool
 265 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 266 isTyVarDict other           = False
 267
 268 isMethod :: Inst -> Bool
 269 isMethod (Method _ _ _ _ _ _) = True
 270 isMethod other                = False
 271
 272 isMethodFor :: TcIdSet -> Inst -> Bool
 273 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 274 isMethodFor ids inst                         = False
 275
 276 isLinearInst :: Inst -> Bool
 277 isLinearInst (Dict _ pred _) = isLinearPred pred
 278 isLinearInst other           = False
 279         -- We never build Method Insts that have
 280         -- linear implicit paramters in them.
 281         -- Hence no need to look for Methods
 282         -- See TcExpr.tcId
 283
 284 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 285 linearInstType (Dict _ (IParam _ ty) _) = ty
 286
 287
 288 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 289                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 290                                         other             -> False
 291 \end{code}
 292
 293 Two predicates which deal with the case where class constraints don't
 294 necessarily result in bindings.  The first tells whether an @Inst@
 295 must be witnessed by an actual binding; the second tells whether an
 296 @Inst@ can be generalised over.
 297
 298 \begin{code}
 299 instBindingRequired :: Inst -> Bool
 300 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 301 instBindingRequired other                      = True
 302
 303 instCanBeGeneralised :: Inst -> Bool
 304 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 305 instCanBeGeneralised other                      = True
 306 \end{code}
 307
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection{Building dictionaries}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 \begin{code}
 316 newDicts :: InstOrigin
 317          -> TcThetaType
 318          -> NF_TcM [Inst]
 319 newDicts orig theta
 320   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 321     newDictsAtLoc loc theta
 322
 323 cloneDict :: Inst -> NF_TcM Inst
 324 cloneDict (Dict id ty loc) = tcGetUnique        `thenNF_Tc` \ uniq ->
 325                              returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
 326
 327 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 328 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 329
 330 -- Local function, similar to newDicts,
 331 -- but with slightly different interface
 332 newDictsAtLoc :: InstLoc
 333               -> TcThetaType
 334               -> NF_TcM [Inst]
 335 newDictsAtLoc inst_loc@(_,loc,_) theta
 336   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 337     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 338   where
 339     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 340
 341 -- For vanilla implicit parameters, there is only one in scope
 342 -- at any time, so we used to use the name of the implicit parameter itself
 343 -- But with splittable implicit parameters there may be many in
 344 -- scope, so we make up a new name.
 345 newIPDict :: InstOrigin -> IPName Name -> Type
 346           -> NF_TcM (IPName Id, Inst)
 347 newIPDict orig ip_name ty
 348   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc@(_,loc,_) ->
 349     tcGetUnique                         `thenNF_Tc` \ uniq ->
 350     let
 351         pred = IParam ip_name ty
 352         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 353     in
 354     returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 355 \end{code}
 356
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection{Building methods (calls of overloaded functions)}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364
 365 \begin{code}
 366 tcInstCall :: InstOrigin  -> TcType -> NF_TcM (TypecheckedHsExpr -> TypecheckedHsExpr, LIE, TcType)
 367 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
 368   = tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
 369     newDicts orig theta         `thenNF_Tc` \ dicts ->
 370     let
 371         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
 372     in
 373     returnNF_Tc (inst_fn, mkLIE dicts, tau)
 374
 375 tcInstDataCon orig data_con
 376   = let
 377         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 378              -- We generate constraints for the stupid theta even when
 379              -- pattern matching (as the Report requires)
 380     in
 381     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
 382     let
 383         stupid_theta' = substTheta tenv stupid_theta
 384         ex_theta'     = substTheta tenv ex_theta
 385         arg_tys'      = map (substTy tenv) arg_tys
 386
 387         n_normal_tvs  = length tvs
 388         ex_tvs'       = drop n_normal_tvs all_tvs'
 389         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
 390     in
 391     newDicts orig stupid_theta' `thenNF_Tc` \ stupid_dicts ->
 392     newDicts orig ex_theta'     `thenNF_Tc` \ ex_dicts ->
 393
 394         -- Note that we return the stupid theta *only* in the LIE;
 395         -- we don't otherwise use it at all
 396     returnNF_Tc (ty_args', map instToId ex_dicts, arg_tys', result_ty,
 397                  mkLIE stupid_dicts, mkLIE ex_dicts, ex_tvs')
 398
 399
 400 newMethodFromName :: InstOrigin -> TcType -> Name -> NF_TcM Inst
 401 newMethodFromName origin ty name
 402   = tcLookupId name             `thenNF_Tc` \ id ->
 403         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 404         -- always a class op, but with -fno-implicit-prelude GHC is
 405         -- meant to find whatever thing is in scope, and that may
 406         -- be an ordinary function.
 407     newMethod origin id [ty]
 408
 409 newMethod :: InstOrigin
 410           -> TcId
 411           -> [TcType]
 412           -> NF_TcM Inst
 413 newMethod orig id tys
 414   =     -- Get the Id type and instantiate it at the specified types
 415     let
 416         (tyvars, rho) = tcSplitForAllTys (idType id)
 417         rho_ty        = substTyWith tyvars tys rho
 418         (pred, tau)   = tcSplitMethodTy rho_ty
 419     in
 420     newMethodWithGivenTy orig id tys [pred] tau
 421
 422 newMethodWithGivenTy orig id tys theta tau
 423   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 424     newMethodWith loc id tys theta tau
 425
 426 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 427   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 428     let
 429         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 430     in
 431     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 432
 433 newMethodAtLoc :: InstLoc
 434                -> Id -> [TcType]
 435                -> NF_TcM (Inst, TcId)
 436 newMethodAtLoc inst_loc real_id tys
 437         -- This actually builds the Inst
 438   =     -- Get the Id type and instantiate it at the specified types
 439     let
 440         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 441         rho_ty        = ASSERT( equalLength tyvars tys )
 442                         substTy (mkTopTyVarSubst tyvars tys) rho
 443         (theta, tau)  = tcSplitPhiTy rho_ty
 444     in
 445     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 446     returnNF_Tc (meth_inst, instToId meth_inst)
 447 \end{code}
 448
 449 In newOverloadedLit we convert directly to an Int or Integer if we
 450 know that's what we want.  This may save some time, by not
 451 temporarily generating overloaded literals, but it won't catch all
 452 cases (the rest are caught in lookupInst).
 453
 454 \begin{code}
 455 newOverloadedLit :: InstOrigin
 456                  -> HsOverLit
 457                  -> TcType
 458                  -> NF_TcM (TcExpr, LIE)
 459 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 460   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
 461                                 -- syntax.  Reason: tcSyntaxName does unification
 462                                 -- which is very inconvenient in tcSimplify
 463   = tcSyntaxName orig expected_ty fromIntegerName fi    `thenTc` \ (expr, lie, _) ->
 464     returnTc (HsApp expr (HsLit (HsInteger i)), lie)
 465
 466   | Just expr <- shortCutIntLit i expected_ty
 467   = returnNF_Tc (expr, emptyLIE)
 468
 469   | otherwise
 470   = newLitInst orig lit expected_ty
 471
 472 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 473   | fr /= fromRationalName      -- c.f. HsIntegral case
 474   = tcSyntaxName orig expected_ty fromRationalName fr   `thenTc` \ (expr, lie, _) ->
 475     mkRatLit r                                          `thenNF_Tc` \ rat_lit ->
 476     returnTc (HsApp expr rat_lit, lie)
 477
 478   | Just expr <- shortCutFracLit r expected_ty
 479   = returnNF_Tc (expr, emptyLIE)
 480
 481   | otherwise
 482   = newLitInst orig lit expected_ty
 483
 484 newLitInst orig lit expected_ty
 485   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 486     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 487     zapToType expected_ty       `thenNF_Tc_`
 488         -- The expected type might be a 'hole' type variable,
 489         -- in which case we must zap it to an ordinary type variable
 490     let
 491         lit_inst = LitInst lit_id lit expected_ty loc
 492         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 493     in
 494     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 495
 496 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
 497 shortCutIntLit i ty
 498   | isIntTy ty && inIntRange i                  -- Short cut for Int
 499   = Just (HsLit (HsInt i))
 500   | isIntegerTy ty                              -- Short cut for Integer
 501   = Just (HsLit (HsInteger i))
 502   | otherwise = Nothing
 503
 504 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
 505 shortCutFracLit f ty
 506   | isFloatTy ty
 507   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 508   | isDoubleTy ty
 509   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 510   | otherwise = Nothing
 511
 512 mkRatLit :: Rational -> NF_TcM TcExpr
 513 mkRatLit r
 514   = tcLookupTyCon rationalTyConName                     `thenNF_Tc` \ rat_tc ->
 515     let
 516         rational_ty  = mkGenTyConApp rat_tc []
 517     in
 518     returnNF_Tc (HsLit (HsRat r rational_ty))
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Zonking}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 Zonking makes sure that the instance types are fully zonked,
 529 but doesn't do the same for any of the Ids in an Inst.  There's no
 530 need, and it's a lot of extra work.
 531
 532 \begin{code}
 533 zonkInst :: Inst -> NF_TcM Inst
 534 zonkInst (Dict id pred loc)
 535   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 536     returnNF_Tc (Dict id new_pred loc)
 537
 538 zonkInst (Method m id tys theta tau loc)
 539   = zonkId id                   `thenNF_Tc` \ new_id ->
 540         -- Essential to zonk the id in case it's a local variable
 541         -- Can't use zonkIdOcc because the id might itself be
 542         -- an InstId, in which case it won't be in scope
 543
 544     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 545     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 546     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 547     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 548
 549 zonkInst (LitInst id lit ty loc)
 550   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 551     returnNF_Tc (LitInst id lit new_ty loc)
 552
 553 zonkInsts insts = mapNF_Tc zonkInst insts
 554 \end{code}
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection{Printing}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 564 relevant in error messages.
 565
 566 \begin{code}
 567 instance Outputable Inst where
 568     ppr inst = pprInst inst
 569
 570 pprInst (LitInst u lit ty loc)
 571   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 572
 573 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 574
 575 pprInst m@(Method u id tys theta tau loc)
 576   = hsep [ppr id, ptext SLIT("at"),
 577           brackets (sep (map pprParendType tys)) {- ,
 578           ptext SLIT("theta"), ppr theta,
 579           ptext SLIT("tau"), ppr tau
 580           show_uniq u,
 581           ppr (instToId m) -}]
 582
 583 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 584
 585 tidyInst :: TidyEnv -> Inst -> Inst
 586 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 587 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 588 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 589
 590 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 591 -- This function doesn't assume that the tyvars are in scope
 592 -- so it works like tidyOpenType, returning a TidyEnv
 593 tidyMoreInsts env insts
 594   = (env', map (tidyInst env') insts)
 595   where
 596     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 597
 598 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 599 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 600 \end{code}
 601
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsection{Looking up Insts}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 \begin{code}
 610 data LookupInstResult s
 611   = NoInstance
 612   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 613   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 614
 615 lookupInst :: Inst
 616            -> NF_TcM (LookupInstResult s)
 617
 618 -- Dictionaries
 619
 620 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 621   = getDOptsTc                  `thenNF_Tc` \ dflags ->
 622     tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 623     case lookupInstEnv dflags inst_env clas tys of
 624
 625       FoundInst tenv dfun_id
 626         ->      -- It's possible that not all the tyvars are in
 627                 -- the substitution, tenv. For example:
 628                 --      instance C X a => D X where ...
 629                 -- (presumably there's a functional dependency in class C)
 630                 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 631            let
 632                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 633                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 634                                    Just (DoneTy ty) -> returnNF_Tc ty
 635                                    Nothing          -> tcInstTyVar VanillaTv tv `thenNF_Tc` \ tc_tv ->
 636                                                        returnTc (mkTyVarTy tc_tv)
 637            in
 638            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 639            let
 640                 dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 641                 (theta, _) = tcSplitPhiTy dfun_rho
 642                 ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 643            in
 644            if null theta then
 645                 returnNF_Tc (SimpleInst ty_app)
 646            else
 647            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 648            let
 649                 rhs = mkHsDictApp ty_app (map instToId dicts)
 650            in
 651            returnNF_Tc (GenInst dicts rhs)
 652
 653       other     -> returnNF_Tc NoInstance
 654
 655 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 656
 657 -- Methods
 658
 659 lookupInst inst@(Method _ id tys theta _ loc)
 660   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 661     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 662
 663 -- Literals
 664
 665 -- Look for short cuts first: if the literal is *definitely* a
 666 -- int, integer, float or a double, generate the real thing here.
 667 -- This is essential  (see nofib/spectral/nucleic).
 668 -- [Same shortcut as in newOverloadedLit, but we
 669 --  may have done some unification by now]
 670
 671 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 672   | Just expr <- shortCutIntLit i ty
 673   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 674                                         -- expr may be a constructor application
 675   | otherwise
 676   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 677     tcLookupGlobalId fromIntegerName            `thenNF_Tc` \ from_integer ->
 678     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 679     returnNF_Tc (GenInst [method_inst]
 680                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 681
 682
 683 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 684   | Just expr <- shortCutFracLit f ty
 685   = returnNF_Tc (GenInst [] expr)
 686
 687   | otherwise
 688   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 689     tcLookupGlobalId fromRationalName           `thenNF_Tc` \ from_rational ->
 690     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 691     mkRatLit f                                  `thenNF_Tc` \ rat_lit ->
 692     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rat_lit))
 693 \end{code}
 694
 695 There is a second, simpler interface, when you want an instance of a
 696 class at a given nullary type constructor.  It just returns the
 697 appropriate dictionary if it exists.  It is used only when resolving
 698 ambiguous dictionaries.
 699
 700 \begin{code}
 701 lookupSimpleInst :: Class
 702                  -> [Type]                      -- Look up (c,t)
 703                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 704
 705 lookupSimpleInst clas tys
 706   = getDOptsTc                  `thenNF_Tc` \ dflags ->
 707     tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 708     case lookupInstEnv dflags inst_env clas tys of
 709       FoundInst tenv dfun
 710         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 711         where
 712            (_, rho)  = tcSplitForAllTys (idType dfun)
 713            (theta,_) = tcSplitPhiTy rho
 714
 715       other  -> returnNF_Tc Nothing
 716 \end{code}
 717
 718
 719 %************************************************************************
 720 %*                                                                      *
 721                 Re-mappable syntax
 722 %*                                                                      *
 723 %************************************************************************
 724
 725
 726 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 727 a do-expression.  We have to find (>>) in the current environment, which is
 728 done by the rename. Then we have to check that it has the same type as
 729 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 730 this:
 731
 732   (>>) :: HB m n mn => m a -> n b -> mn b
 733
 734 So the idea is to generate a local binding for (>>), thus:
 735
 736         let then72 :: forall a b. m a -> m b -> m b
 737             then72 = ...something involving the user's (>>)...
 738         in
 739         ...the do-expression...
 740
 741 Now the do-expression can proceed using then72, which has exactly
 742 the expected type.
 743
 744 In fact tcSyntaxName just generates the RHS for then72, because we only
 745 want an actual binding in the do-expression case. For literals, we can
 746 just use the expression inline.
 747
 748 \begin{code}
 749 tcSyntaxName :: InstOrigin
 750              -> TcType                          -- Type to instantiate it at
 751              -> Name -> Name                    -- (Standard name, user name)
 752              -> TcM (TcExpr, LIE, TcType)       -- Suitable expression with its type
 753
 754 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 755 -- So we do not call it from lookupInst, which is called from tcSimplify
 756
 757 tcSyntaxName orig ty std_nm user_nm
 758   | std_nm == user_nm
 759   = newMethodFromName orig ty std_nm    `thenNF_Tc` \ inst ->
 760     let
 761         id = instToId inst
 762     in
 763     returnTc (HsVar id, unitLIE inst, idType id)
 764
 765   | otherwise
 766   = tcLookupGlobalId std_nm             `thenNF_Tc` \ std_id ->
 767     let
 768         -- C.f. newMethodAtLoc
 769         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 770         tau1            = substTy (mkTopTyVarSubst [tv] [ty]) tau
 771     in
 772     tcAddErrCtxtM (syntaxNameCtxt user_nm orig tau1)    $
 773     tcExpr (HsVar user_nm) tau1                         `thenTc` \ (user_fn, lie) ->
 774     returnTc (user_fn, lie, tau1)
 775
 776 syntaxNameCtxt name orig ty tidy_env
 777   = tcGetInstLoc orig           `thenNF_Tc` \ inst_loc ->
 778     let
 779         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 780                                 ptext SLIT("(needed by a syntactic construct)"),
 781                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 782                     nest 2 (pprInstLoc inst_loc)]
 783     in
 784     returnNF_Tc (tidy_env, msg)
 785 \end{code}