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