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, mkHsDictLam, 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) d@(Dict _ p _)
 280   = if pred p then
 281         returnTc (consLIE d ips, lie)
 282     else
 283         returnTc (ips, consLIE d lie)
 284
 285 partMethod pred (ips, lie) m@(Method u id tys theta tau loc@(_,sloc,_))
 286   = let (ips_, theta_) = partition pred theta in
 287     if null ips_ then
 288         returnTc (ips, consLIE m lie)
 289     else if null theta_ then
 290         returnTc (consLIE m ips, lie)
 291     else
 292         zonkPreds theta_ `thenTc` \ theta_' ->
 293         newDictsAtLoc loc theta_'           `thenTc` \ (new_dicts, _) ->
 294         returnTc (consLIE m ips,
 295                   plusLIE (listToLIE new_dicts) lie)
 296
 297 partMethod pred (ips, lie) inst@(LitInst u lit ty loc)
 298   = returnTc (ips, consLIE inst lie)
 299
 300 tyVarsOfInst :: Inst -> TcTyVarSet
 301 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 302 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 303                                          -- The id might have free type variables; in the case of
 304                                          -- locally-overloaded class methods, for example
 305 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 306 tyVarsOfInst (FunDep _ fds _)
 307   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 308   where tyVarsOfFd (ts1, ts2) =
 309             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
 310
 311 tyVarsOfInsts insts
 312   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 313
 314 tyVarsOfLIE lie
 315   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 316   where insts = lieToList lie
 317 \end{code}
 318
 319 Predicates
 320 ~~~~~~~~~~
 321 \begin{code}
 322 isDict :: Inst -> Bool
 323 isDict (Dict _ _ _) = True
 324 isDict other          = False
 325 isClassDict :: Inst -> Bool
 326 isClassDict (Dict _ (Class _ _) _) = True
 327 isClassDict other             = False
 328
 329 isMethodFor :: TcIdSet -> Inst -> Bool
 330 isMethodFor ids (Method uniq id tys _ _ loc)
 331   = id `elemVarSet` ids
 332 isMethodFor ids inst
 333   = False
 334
 335 isTyVarDict :: Inst -> Bool
 336 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
 337 isTyVarDict other                    = False
 338
 339 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
 340   = isStandardClass clas && isTyVarTy ty
 341 isStdClassTyVarDict other
 342   = False
 343
 344 notFunDep :: Inst -> Bool
 345 notFunDep (FunDep _ _ _) = False
 346 notFunDep other          = True
 347 \end{code}
 348
 349 Two predicates which deal with the case where class constraints don't
 350 necessarily result in bindings.  The first tells whether an @Inst@
 351 must be witnessed by an actual binding; the second tells whether an
 352 @Inst@ can be generalised over.
 353
 354 \begin{code}
 355 instBindingRequired :: Inst -> Bool
 356 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
 357 instBindingRequired (Dict _ (IParam _ _) _)   = False
 358 instBindingRequired other                     = True
 359
 360 instCanBeGeneralised :: Inst -> Bool
 361 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
 362 instCanBeGeneralised other                     = True
 363 \end{code}
 364
 365
 366 Construction
 367 ~~~~~~~~~~~~
 368
 369 \begin{code}
 370 newDicts :: InstOrigin
 371          -> TcThetaType
 372          -> NF_TcM s (LIE, [TcId])
 373 newDicts orig theta
 374   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 375     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 376     returnNF_Tc (listToBag dicts, ids)
 377
 378 newClassDicts :: InstOrigin
 379               -> [(Class,[TcType])]
 380               -> NF_TcM s (LIE, [TcId])
 381 newClassDicts orig theta
 382   = newDicts orig (map (uncurry Class) theta)
 383
 384 -- Local function, similar to newDicts,
 385 -- but with slightly different interface
 386 newDictsAtLoc :: InstLoc
 387               -> TcThetaType
 388               -> NF_TcM s ([Inst], [TcId])
 389 newDictsAtLoc loc theta =
 390  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 391  let
 392   mk_dict u pred = Dict u pred loc
 393   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 394  in
 395  returnNF_Tc (dicts, map instToId dicts)
 396
 397 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 398 newDictFromOld (Dict _ _ loc) clas tys
 399   = tcGetUnique       `thenNF_Tc` \ uniq ->
 400     returnNF_Tc (Dict uniq (Class clas tys) loc)
 401
 402
 403 newMethod :: InstOrigin
 404           -> TcId
 405           -> [TcType]
 406           -> NF_TcM s (LIE, TcId)
 407 newMethod orig id tys
 408   =     -- Get the Id type and instantiate it at the specified types
 409     let
 410         (tyvars, rho) = splitForAllTys (idType id)
 411         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 412         (theta, tau)  = splitRhoTy rho_ty
 413     in
 414     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 415     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 416
 417 instOverloadedFun orig (HsVar v) arg_tys theta tau
 418   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 419     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 420     returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
 421
 422 instFunDeps orig theta
 423   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 424     let ifd (Class clas tys) =
 425             let fds = instantiateFdClassTys clas tys in
 426             if null fds then Nothing else Just (FunDep clas fds loc)
 427         ifd _ = Nothing
 428     in returnNF_Tc (catMaybes (map ifd theta))
 429
 430 newMethodWithGivenTy orig id tys theta tau
 431   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 432     newMethodWith id tys theta tau loc
 433
 434 newMethodWith id tys theta tau loc
 435   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 436     returnNF_Tc (Method new_uniq id tys theta tau loc)
 437
 438 newMethodAtLoc :: InstLoc
 439                -> Id -> [TcType]
 440                -> NF_TcM s (Inst, TcId)
 441 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 442                                         -- slightly different interface
 443   =     -- Get the Id type and instantiate it at the specified types
 444     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 445     let
 446         (tyvars,rho) = splitForAllTys (idType real_id)
 447         rho_ty        = ASSERT( length tyvars == length tys )
 448                         substTy (mkTopTyVarSubst tyvars tys) rho
 449         (theta, tau)  = splitRhoTy rho_ty
 450         meth_inst     = Method new_uniq real_id tys theta tau loc
 451     in
 452     returnNF_Tc (meth_inst, instToId meth_inst)
 453 \end{code}
 454
 455 In newOverloadedLit we convert directly to an Int or Integer if we
 456 know that's what we want.  This may save some time, by not
 457 temporarily generating overloaded literals, but it won't catch all
 458 cases (the rest are caught in lookupInst).
 459
 460 \begin{code}
 461 newOverloadedLit :: InstOrigin
 462                  -> OverloadedLit
 463                  -> TcType
 464                  -> NF_TcM s (TcExpr, LIE)
 465 newOverloadedLit orig (OverloadedIntegral i) ty
 466   | isIntTy ty && inIntRange i          -- Short cut for Int
 467   = returnNF_Tc (int_lit, emptyLIE)
 468
 469   | isIntegerTy ty                      -- Short cut for Integer
 470   = returnNF_Tc (integer_lit, emptyLIE)
 471
 472   where
 473     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 474     integer_lit    = HsLitOut (HsInt i) integerTy
 475     int_lit        = HsCon intDataCon [] [intprim_lit]
 476
 477 newOverloadedLit orig lit ty            -- The general case
 478   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 479     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 480     let
 481         lit_inst = LitInst new_uniq lit ty loc
 482     in
 483     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 484 \end{code}
 485
 486 \begin{code}
 487 newIPDict name ty loc
 488   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 489     let d = Dict new_uniq (IParam name ty) loc in
 490     returnNF_Tc d
 491 \end{code}
 492
 493 \begin{code}
 494 instToId :: Inst -> TcId
 495 instToId inst = instToIdBndr inst
 496
 497 instToIdBndr :: Inst -> TcId
 498 instToIdBndr (Dict u (Class clas ty) (_,loc,_))
 499   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 500 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
 501   = ipToId n ty loc
 502
 503 instToIdBndr (Method u id tys theta tau (_,loc,_))
 504   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 505
 506 instToIdBndr (LitInst u list ty loc)
 507   = mkSysLocal SLIT("lit") u ty
 508
 509 instToIdBndr (FunDep clas fds _)
 510   = panic "FunDep escaped!!!"
 511
 512 ipToId n ty loc
 513   = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 514 \end{code}
 515
 516
 517 Zonking
 518 ~~~~~~~
 519 Zonking makes sure that the instance types are fully zonked,
 520 but doesn't do the same for the Id in a Method.  There's no
 521 need, and it's a lot of extra work.
 522
 523 \begin{code}
 524 zonkPred :: TcPredType -> NF_TcM s TcPredType
 525 zonkPred (Class clas tys)
 526   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 527     returnNF_Tc (Class clas new_tys)
 528 zonkPred (IParam n ty)
 529   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 530     returnNF_Tc (IParam n new_ty)
 531
 532 zonkInst :: Inst -> NF_TcM s Inst
 533 zonkInst (Dict u pred loc)
 534   = zonkPred pred                       `thenNF_Tc` \ new_pred ->
 535     returnNF_Tc (Dict u new_pred loc)
 536
 537 zonkInst (Method u id tys theta tau loc)
 538   = zonkId id                   `thenNF_Tc` \ new_id ->
 539         -- Essential to zonk the id in case it's a local variable
 540         -- Can't use zonkIdOcc because the id might itself be
 541         -- an InstId, in which case it won't be in scope
 542
 543     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 544     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 545     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 546     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 547
 548 zonkInst (LitInst u lit ty loc)
 549   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 550     returnNF_Tc (LitInst u lit new_ty loc)
 551
 552 zonkInst (FunDep clas fds loc)
 553   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 554     returnNF_Tc (FunDep clas fds' loc)
 555
 556 zonkPreds preds = mapNF_Tc zonkPred preds
 557 zonkInsts insts = mapNF_Tc zonkInst insts
 558
 559 zonkFunDeps fds = mapNF_Tc zonkFd fds
 560   where
 561   zonkFd (ts1, ts2)
 562     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 563       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 564       returnNF_Tc (ts1', ts2')
 565
 566 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 567   where
 568   zonkFd (tvs1, tvs2)
 569     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 570       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 571       returnNF_Tc (tvs1', tvs2')
 572 \end{code}
 573
 574
 575 Printing
 576 ~~~~~~~~
 577 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 578 relevant in error messages.
 579
 580 \begin{code}
 581 instance Outputable Inst where
 582     ppr inst = pprInst inst
 583
 584 pprInst (LitInst u lit ty loc)
 585   = hsep [case lit of
 586               OverloadedIntegral   i -> integer i
 587               OverloadedFractional f -> rational f,
 588            ptext SLIT("at"),
 589            ppr ty,
 590            show_uniq u]
 591
 592 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 593
 594 pprInst m@(Method u id tys theta tau loc)
 595   = hsep [ppr id, ptext SLIT("at"),
 596           brackets (interppSP tys),
 597           ppr theta, ppr tau,
 598           show_uniq u,
 599           ppr (instToId m)]
 600
 601 pprInst (FunDep clas fds loc)
 602   = hsep [ppr clas, ppr fds]
 603
 604 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
 605 tidyPred env (Class clas tys)
 606   = (env', Class clas tys')
 607   where
 608     (env', tys') = tidyOpenTypes env tys
 609 tidyPred env (IParam n ty)
 610   = (env', IParam n ty')
 611   where
 612     (env', ty') = tidyOpenType env ty
 613
 614 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 615 tidyInst env (LitInst u lit ty loc)
 616   = (env', LitInst u lit ty' loc)
 617   where
 618     (env', ty') = tidyOpenType env ty
 619
 620 tidyInst env (Dict u pred loc)
 621   = (env', Dict u pred' loc)
 622   where
 623     (env', pred') = tidyPred env pred
 624
 625 tidyInst env (Method u id tys theta tau loc)
 626   = (env', Method u id tys' theta tau loc)
 627                 -- Leave theta, tau alone cos we don't print them
 628   where
 629     (env', tys') = tidyOpenTypes env tys
 630
 631 -- this case shouldn't arise... (we never print fundeps)
 632 tidyInst env fd@(FunDep clas fds loc)
 633   = (env, fd)
 634
 635 tidyInsts env insts = mapAccumL tidyInst env insts
 636
 637 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 638 \end{code}
 639
 640
 641 %************************************************************************
 642 %*                                                                      *
 643 \subsection[InstEnv-types]{Type declarations}
 644 %*                                                                      *
 645 %************************************************************************
 646
 647 \begin{code}
 648 type InstanceMapper = Class -> InstEnv
 649 \end{code}
 650
 651 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 652 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 653 that instance.
 654
 655 There is an important consistency constraint between the @MatchEnv@s
 656 in and the dfun @Id@s inside them: the free type variables of the
 657 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 658 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 659 contain the following entry:
 660 @
 661         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 662 @
 663 The "a" in the pattern must be one of the forall'd variables in
 664 the dfun type.
 665
 666 \begin{code}
 667 data LookupInstResult s
 668   = NoInstance
 669   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 670   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 671
 672 lookupInst :: Inst
 673            -> NF_TcM s (LookupInstResult s)
 674
 675 -- Dictionaries
 676
 677 lookupInst dict@(Dict _ (Class clas tys) loc)
 678   = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
 679
 680       Just (tenv, dfun_id)
 681         -> let
 682                 subst         = mkSubst (tyVarsOfTypes tys) tenv
 683                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 684                 ty_args       = map subst_tv tyvars
 685                 dfun_rho      = substTy subst rho
 686                 (theta, tau)  = splitRhoTy dfun_rho
 687                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 688                 subst_tv tv   = case lookupSubstEnv tenv tv of
 689                                    Just (DoneTy ty)  -> ty
 690                                         -- tenv should bind all the tyvars
 691            in
 692            if null theta then
 693                 returnNF_Tc (SimpleInst ty_app)
 694            else
 695            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 696            let
 697                 rhs = mkHsDictApp ty_app dict_ids
 698            in
 699            returnNF_Tc (GenInst dicts rhs)
 700
 701       Nothing   -> returnNF_Tc NoInstance
 702 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 703
 704 -- Methods
 705
 706 lookupInst inst@(Method _ id tys theta _ loc)
 707   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 708     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 709
 710 -- Literals
 711
 712 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
 713   | isIntTy ty && in_int_range                  -- Short cut for Int
 714   = returnNF_Tc (GenInst [] int_lit)
 715         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 716
 717   | isIntegerTy ty                              -- Short cut for Integer
 718   = returnNF_Tc (GenInst [] integer_lit)
 719
 720   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 721   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 722     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 723     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 724
 725   | otherwise                                   -- Alas, it is overloaded and a big literal!
 726   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 727     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 728     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 729   where
 730     in_int_range   = inIntRange i
 731     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 732     integer_lit    = HsLitOut (HsInt i) integerTy
 733     int_lit        = HsCon intDataCon [] [intprim_lit]
 734
 735 -- similar idea for overloaded floating point literals: if the literal is
 736 -- *definitely* a float or a double, generate the real thing here.
 737 -- This is essential  (see nofib/spectral/nucleic).
 738
 739 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
 740   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 741   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 742
 743   | otherwise
 744           = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 745
 746         -- The type Rational isn't wired in so we have to conjure it up
 747     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 748     let
 749         rational_ty  = mkSynTy rational_tycon []
 750         rational_lit = HsLitOut (HsFrac f) rational_ty
 751     in
 752     newMethodAtLoc loc from_rational [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 753     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 754
 755   where
 756     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 757     float_lit      = HsCon floatDataCon [] [floatprim_lit]
 758     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 759     double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
 760
 761 -- there are no `instances' of functional dependencies or implicit params
 762
 763 lookupInst _  = returnNF_Tc NoInstance
 764
 765 \end{code}
 766
 767 There is a second, simpler interface, when you want an instance of a
 768 class at a given nullary type constructor.  It just returns the
 769 appropriate dictionary if it exists.  It is used only when resolving
 770 ambiguous dictionaries.
 771
 772 \begin{code}
 773 lookupSimpleInst :: InstEnv
 774                  -> Class
 775                  -> [Type]                              -- Look up (c,t)
 776                  -> NF_TcM s (Maybe [(Class,[Type])])   -- Here are the needed (c,t)s
 777
 778 lookupSimpleInst class_inst_env clas tys
 779   = case lookupInstEnv (ppr clas) class_inst_env tys of
 780       Nothing    -> returnNF_Tc Nothing
 781
 782       Just (tenv, dfun)
 783         -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
 784         where
 785            (_, theta, _) = splitSigmaTy (idType dfun)
 786            theta' = map (\(Class clas tys) -> (clas,tys)) theta
 787 \end{code}