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, OverloadedLit(..),
  12         pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
  13
  14         newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
  15         newMethod, newMethodWithGivenTy, newOverloadedLit,
  16         newIPDict, instOverloadedFun,
  17         instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
  18         newFunDepFromDict,
  19
  20         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
  21         getDictPred_maybe, getMethodTheta_maybe,
  22         getFunDeps, getFunDepsOfLIE,
  23         getIPs, getIPsOfLIE,
  24         getAllFunDeps, getAllFunDepsOfLIE,
  25
  26         lookupInst, lookupSimpleInst, LookupInstResult(..),
  27
  28         isDict, isClassDict, isMethod,
  29         isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
  30         instBindingRequired, instCanBeGeneralised,
  31
  32         zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
  33         instToId, instToIdBndr, ipToId,
  34
  35         InstOrigin(..), InstLoc, pprInstLoc
  36     ) where
  37
  38 #include "HsVersions.h"
  39
  40 import HsSyn    ( HsLit(..), HsExpr(..) )
  41 import TcHsSyn  ( TcExpr, TcId,
  42                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  43                 )
  44 import TcMonad
  45 import TcEnv    ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
  46                   tcLookupValueByKey, tcLookupTyConByKey
  47                 )
  48 import TcType   ( TcThetaType,
  49                   TcType, TcTauType, TcTyVarSet,
  50                   zonkTcTyVars, zonkTcType, zonkTcTypes,
  51                   zonkTcThetaType
  52                 )
  53 import Bag
  54 import Class    ( Class, FunDep )
  55 import FunDeps  ( instantiateFdClassTys )
  56 import Id       ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
  57 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  58 import Name     ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
  59                   getOccName, nameUnique )
  60 import PprType  ( pprPred )
  61 import Type     ( Type, PredType(..), ThetaType,
  62                   mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
  63                   splitForAllTys, splitSigmaTy,
  64                   splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
  65                   mkSynTy, tidyOpenType, tidyOpenTypes
  66                 )
  67 import Subst    ( emptyInScopeSet, mkSubst,
  68                   substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
  69                 )
  70 import Literal  ( inIntRange )
  71 import VarEnv   ( lookupVarEnv, TidyEnv,
  72                   lookupSubstEnv, SubstResult(..)
  73                 )
  74 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  75 import TysPrim    ( intPrimTy, floatPrimTy, doublePrimTy )
  76 import TysWiredIn ( intDataCon, isIntTy,
  77                     floatDataCon, isFloatTy,
  78                     doubleDataCon, isDoubleTy,
  79                     integerTy, isIntegerTy,
  80                     voidTy
  81                   )
  82 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  83                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  84                 )
  85 import Maybe    ( catMaybes )
  86 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  87 import Outputable
  88 \end{code}
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 \subsection[Inst-collections]{LIE: a collection of Insts}
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 \begin{code}
  97 type LIE = Bag Inst
  98
  99 isEmptyLIE        = isEmptyBag
 100 emptyLIE          = emptyBag
 101 unitLIE inst      = unitBag inst
 102 mkLIE insts       = listToBag insts
 103 plusLIE lie1 lie2 = lie1 `unionBags` lie2
 104 consLIE inst lie  = inst `consBag` lie
 105 plusLIEs lies     = unionManyBags lies
 106 lieToList         = bagToList
 107 listToLIE         = listToBag
 108
 109 zonkLIE :: LIE -> NF_TcM s LIE
 110 zonkLIE lie = mapBagNF_Tc zonkInst lie
 111
 112 pprInsts :: [Inst] -> SDoc
 113 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 114
 115
 116 pprInstsInFull insts
 117   = vcat (map go insts)
 118   where
 119     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 120 \end{code}
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection[Inst-types]{@Inst@ types}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 An @Inst@ is either a dictionary, an instance of an overloaded
 129 literal, or an instance of an overloaded value.  We call the latter a
 130 ``method'' even though it may not correspond to a class operation.
 131 For example, we might have an instance of the @double@ function at
 132 type Int, represented by
 133
 134         Method 34 doubleId [Int] origin
 135
 136 \begin{code}
 137 data Inst
 138   = Dict
 139         Unique
 140         TcPredType
 141         InstLoc
 142
 143   | Method
 144         Unique
 145
 146         TcId    -- The overloaded function
 147                         -- This function will be a global, local, or ClassOpId;
 148                         --   inside instance decls (only) it can also be an InstId!
 149                         -- The id needn't be completely polymorphic.
 150                         -- You'll probably find its name (for documentation purposes)
 151                         --        inside the InstOrigin
 152
 153         [TcType]        -- The types to which its polymorphic tyvars
 154                         --      should be instantiated.
 155                         -- These types must saturate the Id's foralls.
 156
 157         TcThetaType     -- The (types of the) dictionaries to which the function
 158                         -- must be applied to get the method
 159
 160         TcTauType       -- The type of the method
 161
 162         InstLoc
 163
 164         -- INVARIANT: in (Method u f tys theta tau loc)
 165         --      type of (f tys dicts(from theta)) = tau
 166
 167   | LitInst
 168         Unique
 169         OverloadedLit
 170         TcType          -- The type at which the literal is used
 171         InstLoc
 172
 173   | FunDep
 174         Unique
 175         Class           -- the class from which this arises
 176         [FunDep TcType]
 177         InstLoc
 178
 179 data OverloadedLit
 180   = OverloadedIntegral   Integer        -- The number
 181   | OverloadedFractional Rational       -- The number
 182 \end{code}
 183
 184 Ordering
 185 ~~~~~~~~
 186 @Insts@ are ordered by their class/type info, rather than by their
 187 unique.  This allows the context-reduction mechanism to use standard finite
 188 maps to do their stuff.
 189
 190 \begin{code}
 191 instance Ord Inst where
 192   compare = cmpInst
 193
 194 instance Eq Inst where
 195   (==) i1 i2 = case i1 `cmpInst` i2 of
 196                  EQ    -> True
 197                  other -> False
 198
 199 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = (pred1 `compare` pred2)
 200 cmpInst (Dict _ _ _)              other                     = LT
 201
 202 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 203 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 204 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 205
 206 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 207 cmpInst (LitInst _ _ _ _)         (FunDep _ _ _ _)          = LT
 208 cmpInst (LitInst _ _ _ _)         other                     = GT
 209
 210 cmpInst (FunDep _ clas1 fds1 _)   (FunDep _ clas2 fds2 _)   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
 211 cmpInst (FunDep _ _ _ _)          other                     = GT
 212
 213 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 214 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 215 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 216 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 217 \end{code}
 218
 219
 220 Selection
 221 ~~~~~~~~~
 222 \begin{code}
 223 instLoc (Dict   u pred      loc) = loc
 224 instLoc (Method u _ _ _ _   loc) = loc
 225 instLoc (LitInst u lit ty   loc) = loc
 226 instLoc (FunDep _ _ _       loc) = loc
 227
 228 getDictPred_maybe (Dict _ p _) = Just p
 229 getDictPred_maybe _            = Nothing
 230
 231 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
 232 getMethodTheta_maybe _                        = Nothing
 233
 234 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
 235
 236 getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
 237 getFunDeps _ = Nothing
 238
 239 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
 240
 241 getIPsOfPred (IParam n ty) = [(n, ty)]
 242 getIPsOfPred _             = []
 243 getIPsOfTheta theta = concatMap getIPsOfPred theta
 244
 245 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
 246 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
 247 getIPs _ = []
 248
 249 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
 250
 251 getAllFunDeps (FunDep _ clas fds _) = fds
 252 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
 253
 254 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
 255
 256 tyVarsOfInst :: Inst -> TcTyVarSet
 257 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 258 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 259                                          -- The id might have free type variables; in the case of
 260                                          -- locally-overloaded class methods, for example
 261 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 262 tyVarsOfInst (FunDep _ _ fds _)
 263   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 264   where tyVarsOfFd (ts1, ts2) =
 265             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
 266
 267 tyVarsOfInsts insts
 268   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 269
 270 tyVarsOfLIE lie
 271   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 272   where insts = lieToList lie
 273 \end{code}
 274
 275 Predicates
 276 ~~~~~~~~~~
 277 \begin{code}
 278 isDict :: Inst -> Bool
 279 isDict (Dict _ _ _) = True
 280 isDict other        = False
 281
 282 isClassDict :: Inst -> Bool
 283 isClassDict (Dict _ (Class _ _) _) = True
 284 isClassDict other                  = False
 285
 286 isMethod :: Inst -> Bool
 287 isMethod (Method _ _ _ _ _ _) = True
 288 isMethod other                = False
 289
 290 isMethodFor :: TcIdSet -> Inst -> Bool
 291 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 292 isMethodFor ids inst                         = False
 293
 294 isTyVarDict :: Inst -> Bool
 295 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
 296 isTyVarDict other                    = False
 297
 298 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
 299   = isStandardClass clas && isTyVarTy ty
 300 isStdClassTyVarDict other
 301   = False
 302
 303 notFunDep :: Inst -> Bool
 304 notFunDep (FunDep _ _ _ _) = False
 305 notFunDep other            = True
 306 \end{code}
 307
 308 Two predicates which deal with the case where class constraints don't
 309 necessarily result in bindings.  The first tells whether an @Inst@
 310 must be witnessed by an actual binding; the second tells whether an
 311 @Inst@ can be generalised over.
 312
 313 \begin{code}
 314 instBindingRequired :: Inst -> Bool
 315 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
 316 instBindingRequired (Dict _ (IParam _ _) _)   = False
 317 instBindingRequired other                     = True
 318
 319 instCanBeGeneralised :: Inst -> Bool
 320 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
 321 instCanBeGeneralised other                     = True
 322 \end{code}
 323
 324
 325 Construction
 326 ~~~~~~~~~~~~
 327
 328 \begin{code}
 329 newDicts :: InstOrigin
 330          -> TcThetaType
 331          -> NF_TcM s (LIE, [TcId])
 332 newDicts orig theta
 333   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 334     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 335     returnNF_Tc (listToBag dicts, ids)
 336
 337 newClassDicts :: InstOrigin
 338               -> [(Class,[TcType])]
 339               -> NF_TcM s (LIE, [TcId])
 340 newClassDicts orig theta
 341   = newDicts orig (map (uncurry Class) theta)
 342
 343 -- Local function, similar to newDicts,
 344 -- but with slightly different interface
 345 newDictsAtLoc :: InstLoc
 346               -> TcThetaType
 347               -> NF_TcM s ([Inst], [TcId])
 348 newDictsAtLoc loc theta =
 349  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 350  let
 351   mk_dict u pred = Dict u pred loc
 352   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 353  in
 354  returnNF_Tc (dicts, map instToId dicts)
 355
 356 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 357 newDictFromOld (Dict _ _ loc) clas tys
 358   = tcGetUnique       `thenNF_Tc` \ uniq ->
 359     returnNF_Tc (Dict uniq (Class clas tys) loc)
 360
 361
 362 newMethod :: InstOrigin
 363           -> TcId
 364           -> [TcType]
 365           -> NF_TcM s (LIE, TcId)
 366 newMethod orig id tys
 367   =     -- Get the Id type and instantiate it at the specified types
 368     let
 369         (tyvars, rho) = splitForAllTys (idType id)
 370         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 371         (theta, tau)  = splitRhoTy rho_ty
 372     in
 373     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 374     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 375
 376 instOverloadedFun orig v arg_tys theta tau
 377 -- This is where we introduce new functional dependencies into the LIE
 378   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 379     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 380     returnNF_Tc (instToId inst, mkLIE (inst : fds))
 381
 382 instFunDeps orig theta
 383   = tcGetUnique         `thenNF_Tc` \ uniq ->
 384     tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 385     let ifd (Class clas tys) =
 386             let fds = instantiateFdClassTys clas tys in
 387             if null fds then Nothing else Just (FunDep uniq clas fds loc)
 388         ifd _ = Nothing
 389     in returnNF_Tc (catMaybes (map ifd theta))
 390
 391 instFunDepsOfTheta theta
 392   = let ifd (Class clas tys) = instantiateFdClassTys clas tys
 393         ifd (IParam n ty)    = [([], [ty])]
 394     in concat (map ifd theta)
 395
 396 newMethodWithGivenTy orig id tys theta tau
 397   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 398     newMethodWith id tys theta tau loc
 399
 400 newMethodWith id tys theta tau loc
 401   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 402     returnNF_Tc (Method new_uniq id tys theta tau loc)
 403
 404 newMethodAtLoc :: InstLoc
 405                -> Id -> [TcType]
 406                -> NF_TcM s (Inst, TcId)
 407 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 408                                         -- slightly different interface
 409   =     -- Get the Id type and instantiate it at the specified types
 410     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 411     let
 412         (tyvars,rho) = splitForAllTys (idType real_id)
 413         rho_ty        = ASSERT( length tyvars == length tys )
 414                         substTy (mkTopTyVarSubst tyvars tys) rho
 415         (theta, tau)  = splitRhoTy rho_ty
 416         meth_inst     = Method new_uniq real_id tys theta tau loc
 417     in
 418     returnNF_Tc (meth_inst, instToId meth_inst)
 419 \end{code}
 420
 421 In newOverloadedLit we convert directly to an Int or Integer if we
 422 know that's what we want.  This may save some time, by not
 423 temporarily generating overloaded literals, but it won't catch all
 424 cases (the rest are caught in lookupInst).
 425
 426 \begin{code}
 427 newOverloadedLit :: InstOrigin
 428                  -> OverloadedLit
 429                  -> TcType
 430                  -> NF_TcM s (TcExpr, LIE)
 431 newOverloadedLit orig (OverloadedIntegral i) ty
 432   | isIntTy ty && inIntRange i          -- Short cut for Int
 433   = returnNF_Tc (int_lit, emptyLIE)
 434
 435   | isIntegerTy ty                      -- Short cut for Integer
 436   = returnNF_Tc (integer_lit, emptyLIE)
 437
 438   where
 439     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 440     integer_lit    = HsLitOut (HsInt i) integerTy
 441     int_lit        = mkHsConApp intDataCon [] [intprim_lit]
 442
 443 newOverloadedLit orig lit ty            -- The general case
 444   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 445     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 446     let
 447         lit_inst = LitInst new_uniq lit ty loc
 448     in
 449     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 450 \end{code}
 451
 452 \begin{code}
 453 newFunDepFromDict dict
 454   = tcGetUnique         `thenNF_Tc` \ uniq ->
 455     let (clas, tys) = getDictClassTys dict
 456         fds = instantiateFdClassTys clas tys
 457         inst = FunDep uniq clas fds (instLoc dict)
 458     in
 459         if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
 460 \end{code}
 461
 462 \begin{code}
 463 newIPDict name ty loc
 464   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 465     let d = Dict new_uniq (IParam name ty) loc in
 466     returnNF_Tc d
 467 \end{code}
 468
 469 \begin{code}
 470 instToId :: Inst -> TcId
 471 instToId inst = instToIdBndr inst
 472
 473 instToIdBndr :: Inst -> TcId
 474 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
 475   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
 476 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
 477   = ipToId n ty loc
 478
 479 instToIdBndr (Method u id tys theta tau (_,loc,_))
 480   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 481
 482 instToIdBndr (LitInst u list ty loc)
 483   = mkSysLocal SLIT("lit") u ty
 484
 485 instToIdBndr (FunDep u clas fds _)
 486   = mkSysLocal SLIT("FunDep") u voidTy
 487
 488 ipToId n ty loc
 489   = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 490 \end{code}
 491
 492
 493 Zonking
 494 ~~~~~~~
 495 Zonking makes sure that the instance types are fully zonked,
 496 but doesn't do the same for the Id in a Method.  There's no
 497 need, and it's a lot of extra work.
 498
 499 \begin{code}
 500 zonkPred :: TcPredType -> NF_TcM s TcPredType
 501 zonkPred (Class clas tys)
 502   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 503     returnNF_Tc (Class clas new_tys)
 504 zonkPred (IParam n ty)
 505   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 506     returnNF_Tc (IParam n new_ty)
 507
 508 zonkInst :: Inst -> NF_TcM s Inst
 509 zonkInst (Dict u pred loc)
 510   = zonkPred pred                       `thenNF_Tc` \ new_pred ->
 511     returnNF_Tc (Dict u new_pred loc)
 512
 513 zonkInst (Method u id tys theta tau loc)
 514   = zonkId id                   `thenNF_Tc` \ new_id ->
 515         -- Essential to zonk the id in case it's a local variable
 516         -- Can't use zonkIdOcc because the id might itself be
 517         -- an InstId, in which case it won't be in scope
 518
 519     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 520     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 521     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 522     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 523
 524 zonkInst (LitInst u lit ty loc)
 525   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 526     returnNF_Tc (LitInst u lit new_ty loc)
 527
 528 zonkInst (FunDep u clas fds loc)
 529   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 530     returnNF_Tc (FunDep u clas fds' loc)
 531
 532 zonkPreds preds = mapNF_Tc zonkPred preds
 533 zonkInsts insts = mapNF_Tc zonkInst insts
 534
 535 zonkFunDeps fds = mapNF_Tc zonkFd fds
 536   where
 537   zonkFd (ts1, ts2)
 538     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 539       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 540       returnNF_Tc (ts1', ts2')
 541
 542 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 543   where
 544   zonkFd (tvs1, tvs2)
 545     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 546       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 547       returnNF_Tc (tvs1', tvs2')
 548 \end{code}
 549
 550
 551 Printing
 552 ~~~~~~~~
 553 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 554 relevant in error messages.
 555
 556 \begin{code}
 557 instance Outputable Inst where
 558     ppr inst = pprInst inst
 559
 560 pprInst (LitInst u lit ty loc)
 561   = hsep [case lit of
 562               OverloadedIntegral   i -> integer i
 563               OverloadedFractional f -> rational f,
 564            ptext SLIT("at"),
 565            ppr ty,
 566            show_uniq u]
 567
 568 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 569
 570 pprInst m@(Method u id tys theta tau loc)
 571   = hsep [ppr id, ptext SLIT("at"),
 572           brackets (interppSP tys) {- ,
 573           ppr theta, ppr tau,
 574           show_uniq u,
 575           ppr (instToId m) -}]
 576
 577 pprInst (FunDep _ clas fds loc)
 578   = hsep [ppr clas, ppr fds]
 579
 580 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
 581 tidyPred env (Class clas tys)
 582   = (env', Class clas tys')
 583   where
 584     (env', tys') = tidyOpenTypes env tys
 585 tidyPred env (IParam n ty)
 586   = (env', IParam n ty')
 587   where
 588     (env', ty') = tidyOpenType env ty
 589
 590 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 591 tidyInst env (LitInst u lit ty loc)
 592   = (env', LitInst u lit ty' loc)
 593   where
 594     (env', ty') = tidyOpenType env ty
 595
 596 tidyInst env (Dict u pred loc)
 597   = (env', Dict u pred' loc)
 598   where
 599     (env', pred') = tidyPred env pred
 600
 601 tidyInst env (Method u id tys theta tau loc)
 602   = (env', Method u id tys' theta tau loc)
 603                 -- Leave theta, tau alone cos we don't print them
 604   where
 605     (env', tys') = tidyOpenTypes env tys
 606
 607 -- this case shouldn't arise... (we never print fundeps)
 608 tidyInst env fd@(FunDep _ clas fds loc)
 609   = (env, fd)
 610
 611 tidyInsts env insts = mapAccumL tidyInst env insts
 612
 613 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsection[InstEnv-types]{Type declarations}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 data LookupInstResult s
 625   = NoInstance
 626   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 627   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 628
 629 lookupInst :: Inst
 630            -> NF_TcM s (LookupInstResult s)
 631
 632 -- Dictionaries
 633
 634 lookupInst dict@(Dict _ (Class clas tys) loc)
 635   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 636     case lookupInstEnv inst_env clas tys of
 637
 638       FoundInst tenv dfun_id
 639         -> let
 640                 subst         = mkSubst (tyVarsOfTypes tys) tenv
 641                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 642                 ty_args       = map subst_tv tyvars
 643                 dfun_rho      = substTy subst rho
 644                 (theta, tau)  = splitRhoTy dfun_rho
 645                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 646                 subst_tv tv   = case lookupSubstEnv tenv tv of
 647                                    Just (DoneTy ty)  -> ty
 648                                         -- tenv should bind all the tyvars
 649            in
 650            if null theta then
 651                 returnNF_Tc (SimpleInst ty_app)
 652            else
 653            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 654            let
 655                 rhs = mkHsDictApp ty_app dict_ids
 656            in
 657            returnNF_Tc (GenInst dicts rhs)
 658
 659       other     -> returnNF_Tc NoInstance
 660 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 661
 662 -- Methods
 663
 664 lookupInst inst@(Method _ id tys theta _ loc)
 665   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 666     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 667
 668 -- Literals
 669
 670 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
 671   | isIntTy ty && in_int_range                  -- Short cut for Int
 672   = returnNF_Tc (GenInst [] int_lit)
 673         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 674
 675   | isIntegerTy ty                              -- Short cut for Integer
 676   = returnNF_Tc (GenInst [] integer_lit)
 677
 678   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 679   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 680     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 681     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 682
 683   | otherwise                                   -- Alas, it is overloaded and a big literal!
 684   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 685     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 686     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 687   where
 688     in_int_range   = inIntRange i
 689     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 690     integer_lit    = HsLitOut (HsInt i) integerTy
 691     int_lit        = mkHsConApp intDataCon [] [intprim_lit]
 692
 693 -- similar idea for overloaded floating point literals: if the literal is
 694 -- *definitely* a float or a double, generate the real thing here.
 695 -- This is essential  (see nofib/spectral/nucleic).
 696
 697 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
 698   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 699   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 700
 701   | otherwise
 702   = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 703
 704         -- The type Rational isn't wired in so we have to conjure it up
 705     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 706     let
 707         rational_ty  = mkSynTy rational_tycon []
 708         rational_lit = HsLitOut (HsFrac f) rational_ty
 709     in
 710     newMethodAtLoc loc from_rational [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 711     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 712
 713   where
 714     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 715     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 716     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 717     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 718
 719 -- there are no `instances' of functional dependencies or implicit params
 720
 721 lookupInst _  = returnNF_Tc NoInstance
 722
 723 \end{code}
 724
 725 There is a second, simpler interface, when you want an instance of a
 726 class at a given nullary type constructor.  It just returns the
 727 appropriate dictionary if it exists.  It is used only when resolving
 728 ambiguous dictionaries.
 729
 730 \begin{code}
 731 lookupSimpleInst :: Class
 732                  -> [Type]                              -- Look up (c,t)
 733                  -> NF_TcM s (Maybe [(Class,[Type])])   -- Here are the needed (c,t)s
 734
 735 lookupSimpleInst clas tys
 736   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 737     case lookupInstEnv inst_env clas tys of
 738       FoundInst tenv dfun
 739         -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
 740         where
 741            (_, theta, _) = splitSigmaTy (idType dfun)
 742            theta' = map (\(Class clas tys) -> (clas,tys)) theta
 743
 744       other  -> returnNF_Tc Nothing
 745 \end{code}
 746
 747