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