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, funArgTy,
  64                   splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
  65                   mkSynTy, tidyOpenType, tidyOpenTypes
  66                 )
  67 import Subst    ( emptyInScopeSet, mkSubst, mkInScopeSet,
  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   | isClassDict dict
 455   = tcGetUnique         `thenNF_Tc` \ uniq ->
 456     let (clas, tys) = getDictClassTys dict
 457         fds = instantiateFdClassTys clas tys
 458         inst = FunDep uniq clas fds (instLoc dict)
 459     in
 460         if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
 461   | otherwise
 462   = returnNF_Tc Nothing
 463 \end{code}
 464
 465 \begin{code}
 466 newIPDict name ty loc
 467   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 468     let d = Dict new_uniq (IParam name ty) loc in
 469     returnNF_Tc d
 470 \end{code}
 471
 472 \begin{code}
 473 instToId :: Inst -> TcId
 474 instToId inst = instToIdBndr inst
 475
 476 instToIdBndr :: Inst -> TcId
 477 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
 478   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
 479 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
 480   = ipToId n ty loc
 481
 482 instToIdBndr (Method u id tys theta tau (_,loc,_))
 483   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 484
 485 instToIdBndr (LitInst u list ty loc)
 486   = mkSysLocal SLIT("lit") u ty
 487
 488 instToIdBndr (FunDep u clas fds _)
 489   = mkSysLocal SLIT("FunDep") u voidTy
 490
 491 ipToId n ty loc
 492   = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 493 \end{code}
 494
 495
 496 Zonking
 497 ~~~~~~~
 498 Zonking makes sure that the instance types are fully zonked,
 499 but doesn't do the same for the Id in a Method.  There's no
 500 need, and it's a lot of extra work.
 501
 502 \begin{code}
 503 zonkPred :: TcPredType -> NF_TcM s TcPredType
 504 zonkPred (Class clas tys)
 505   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 506     returnNF_Tc (Class clas new_tys)
 507 zonkPred (IParam n ty)
 508   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 509     returnNF_Tc (IParam n new_ty)
 510
 511 zonkInst :: Inst -> NF_TcM s Inst
 512 zonkInst (Dict u pred loc)
 513   = zonkPred pred                       `thenNF_Tc` \ new_pred ->
 514     returnNF_Tc (Dict u new_pred loc)
 515
 516 zonkInst (Method u id tys theta tau loc)
 517   = zonkId id                   `thenNF_Tc` \ new_id ->
 518         -- Essential to zonk the id in case it's a local variable
 519         -- Can't use zonkIdOcc because the id might itself be
 520         -- an InstId, in which case it won't be in scope
 521
 522     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 523     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 524     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 525     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 526
 527 zonkInst (LitInst u lit ty loc)
 528   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 529     returnNF_Tc (LitInst u lit new_ty loc)
 530
 531 zonkInst (FunDep u clas fds loc)
 532   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 533     returnNF_Tc (FunDep u clas fds' loc)
 534
 535 zonkPreds preds = mapNF_Tc zonkPred preds
 536 zonkInsts insts = mapNF_Tc zonkInst insts
 537
 538 zonkFunDeps fds = mapNF_Tc zonkFd fds
 539   where
 540   zonkFd (ts1, ts2)
 541     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 542       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 543       returnNF_Tc (ts1', ts2')
 544
 545 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 546   where
 547   zonkFd (tvs1, tvs2)
 548     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 549       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 550       returnNF_Tc (tvs1', tvs2')
 551 \end{code}
 552
 553
 554 Printing
 555 ~~~~~~~~
 556 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 557 relevant in error messages.
 558
 559 \begin{code}
 560 instance Outputable Inst where
 561     ppr inst = pprInst inst
 562
 563 pprInst (LitInst u lit ty loc)
 564   = hsep [case lit of
 565               OverloadedIntegral   i -> integer i
 566               OverloadedFractional f -> rational f,
 567            ptext SLIT("at"),
 568            ppr ty,
 569            show_uniq u]
 570
 571 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 572
 573 pprInst m@(Method u id tys theta tau loc)
 574   = hsep [ppr id, ptext SLIT("at"),
 575           brackets (interppSP tys) {- ,
 576           ppr theta, ppr tau,
 577           show_uniq u,
 578           ppr (instToId m) -}]
 579
 580 pprInst (FunDep _ clas fds loc)
 581   = hsep [ppr clas, ppr fds]
 582
 583 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
 584 tidyPred env (Class clas tys)
 585   = (env', Class clas tys')
 586   where
 587     (env', tys') = tidyOpenTypes env tys
 588 tidyPred env (IParam n ty)
 589   = (env', IParam n ty')
 590   where
 591     (env', ty') = tidyOpenType env ty
 592
 593 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 594 tidyInst env (LitInst u lit ty loc)
 595   = (env', LitInst u lit ty' loc)
 596   where
 597     (env', ty') = tidyOpenType env ty
 598
 599 tidyInst env (Dict u pred loc)
 600   = (env', Dict u pred' loc)
 601   where
 602     (env', pred') = tidyPred env pred
 603
 604 tidyInst env (Method u id tys theta tau loc)
 605   = (env', Method u id tys' theta tau loc)
 606                 -- Leave theta, tau alone cos we don't print them
 607   where
 608     (env', tys') = tidyOpenTypes env tys
 609
 610 -- this case shouldn't arise... (we never print fundeps)
 611 tidyInst env fd@(FunDep _ clas fds loc)
 612   = (env, fd)
 613
 614 tidyInsts env insts = mapAccumL tidyInst env insts
 615
 616 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 617 \end{code}
 618
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsection[InstEnv-types]{Type declarations}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 \begin{code}
 627 data LookupInstResult s
 628   = NoInstance
 629   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 630   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 631
 632 lookupInst :: Inst
 633            -> NF_TcM s (LookupInstResult s)
 634
 635 -- Dictionaries
 636
 637 lookupInst dict@(Dict _ (Class clas tys) loc)
 638   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 639     case lookupInstEnv inst_env clas tys of
 640
 641       FoundInst tenv dfun_id
 642         -> let
 643                 subst         = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
 644                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 645                 ty_args       = map subst_tv tyvars
 646                 dfun_rho      = substTy subst rho
 647                 (theta, tau)  = splitRhoTy dfun_rho
 648                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 649                 subst_tv tv   = case lookupSubstEnv tenv tv of
 650                                    Just (DoneTy ty)  -> ty
 651                                         -- tenv should bind all the tyvars
 652            in
 653            if null theta then
 654                 returnNF_Tc (SimpleInst ty_app)
 655            else
 656            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 657            let
 658                 rhs = mkHsDictApp ty_app dict_ids
 659            in
 660            returnNF_Tc (GenInst dicts rhs)
 661
 662       other     -> returnNF_Tc NoInstance
 663 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 664
 665 -- Methods
 666
 667 lookupInst inst@(Method _ id tys theta _ loc)
 668   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 669     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 670
 671 -- Literals
 672
 673 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
 674   | isIntTy ty && in_int_range                  -- Short cut for Int
 675   = returnNF_Tc (GenInst [] int_lit)
 676         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 677
 678   | isIntegerTy ty                              -- Short cut for Integer
 679   = returnNF_Tc (GenInst [] integer_lit)
 680
 681   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 682   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 683     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 684     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 685
 686   | otherwise                                   -- Alas, it is overloaded and a big literal!
 687   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 688     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 689     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 690   where
 691     in_int_range   = inIntRange i
 692     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 693     integer_lit    = HsLitOut (HsInt i) integerTy
 694     int_lit        = mkHsConApp intDataCon [] [intprim_lit]
 695
 696 -- similar idea for overloaded floating point literals: if the literal is
 697 -- *definitely* a float or a double, generate the real thing here.
 698 -- This is essential  (see nofib/spectral/nucleic).
 699
 700 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
 701   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 702   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 703
 704   | otherwise
 705   = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 706     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 707     let
 708         rational_ty  = funArgTy (idType method_id)
 709         rational_lit = HsLitOut (HsFrac f) rational_ty
 710     in
 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