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