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,
   9         plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
  10         showLIE,
  11
  12         Inst,
  13         pprInst, pprInsts, pprInstsInFull, pprDFuns,
  14         tidyInsts, tidyMoreInsts,
  15
  16         newDictsFromOld, newDicts, cloneDict,
  17         newOverloadedLit, newIPDict,
  18         newMethod, newMethodFromName, newMethodWithGivenTy,
  19         tcInstClassOp, tcInstCall, tcInstDataCon,
  20         tcSyntaxName, tcStdSyntaxName,
  21
  22         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  23         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  24         instLoc, getDictClassTys, dictPred,
  25
  26         lookupInst, LookupInstResult(..),
  27         tcExtendLocalInstEnv, tcGetInstEnvs,
  28
  29         isDict, isClassDict, isMethod,
  30         isLinearInst, linearInstType, isIPDict, isInheritableInst,
  31         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  32         instBindingRequired,
  33
  34         zonkInst, zonkInsts,
  35         instToId, instName,
  36
  37         InstOrigin(..), InstLoc(..), pprInstLoc
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import {-# SOURCE #-}   TcExpr( tcCheckSigma )
  43
  44 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  45 import TcHsSyn  ( TcExpr, TcId, TcIdSet,
  46                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
  47                   mkCoercion, ExprCoFn
  48                 )
  49 import TcRnMonad
  50 import TcEnv    ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
  51 import InstEnv  ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
  52 import TcIface  ( loadImportedInsts )
  53 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  54                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  55                 )
  56 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet,
  57                   PredType(..), TyVarDetails(VanillaTv),
  58                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  59                   tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
  60                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  61                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  62                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  63                   isClassPred, isTyVarClassPred, isLinearPred,
  64                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  65                   isInheritablePred, isIPPred, matchTys,
  66                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
  67                   pprPred, pprParendType, pprThetaArrow, pprClassPred
  68                 )
  69 import HscTypes ( ExternalPackageState(..) )
  70 import CoreFVs  ( idFreeTyVars )
  71 import DataCon  ( DataCon,dataConSig )
  72 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  73 import PrelInfo ( isStandardClass, isNoDictClass )
  74 import Name     ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
  75 import NameSet  ( addOneToNameSet )
  76 import Subst    ( substTy, substTyWith, substTheta, mkTyVarSubst )
  77 import Literal  ( inIntRange )
  78 import Var      ( TyVar )
  79 import VarEnv   ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
  80 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
  81 import TysWiredIn ( floatDataCon, doubleDataCon )
  82 import PrelNames        ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
  83 import BasicTypes( IPName(..), mapIPName, ipNameName )
  84 import UniqSupply( uniqsFromSupply )
  85 import CmdLineOpts( DynFlags )
  86 import Maybes   ( isJust )
  87 import Outputable
  88 \end{code}
  89
  90
  91 Selection
  92 ~~~~~~~~~
  93 \begin{code}
  94 instName :: Inst -> Name
  95 instName inst = idName (instToId inst)
  96
  97 instToId :: Inst -> TcId
  98 instToId (Dict id _ _)         = id
  99 instToId (Method id _ _ _ _ _) = id
 100 instToId (LitInst id _ _ _)    = id
 101
 102 instLoc (Dict _ _         loc) = loc
 103 instLoc (Method _ _ _ _ _ loc) = loc
 104 instLoc (LitInst _ _ _    loc) = loc
 105
 106 dictPred (Dict _ pred _ ) = pred
 107 dictPred inst             = pprPanic "dictPred" (ppr inst)
 108
 109 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 110
 111 -- fdPredsOfInst is used to get predicates that contain functional
 112 -- dependencies *or* might do so.  The "might do" part is because
 113 -- a constraint (C a b) might have a superclass with FDs
 114 -- Leaving these in is really important for the call to fdPredsOfInsts
 115 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 116 -- which is supposed to be conservative
 117 fdPredsOfInst (Dict _ pred _)          = [pred]
 118 fdPredsOfInst (Method _ _ _ theta _ _) = theta
 119 fdPredsOfInst other                    = []     -- LitInsts etc
 120
 121 fdPredsOfInsts :: [Inst] -> [PredType]
 122 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 123
 124 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
 125 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
 126 isInheritableInst other                    = True
 127
 128
 129 ipNamesOfInsts :: [Inst] -> [Name]
 130 ipNamesOfInst  :: Inst   -> [Name]
 131 -- Get the implicit parameters mentioned by these Insts
 132 -- NB: ?x and %x get different Names
 133 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 134
 135 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 136 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 137 ipNamesOfInst other                    = []
 138
 139 tyVarsOfInst :: Inst -> TcTyVarSet
 140 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 141 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 142 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 143                                          -- The id might have free type variables; in the case of
 144                                          -- locally-overloaded class methods, for example
 145
 146
 147 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 148 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 149 \end{code}
 150
 151 Predicates
 152 ~~~~~~~~~~
 153 \begin{code}
 154 isDict :: Inst -> Bool
 155 isDict (Dict _ _ _) = True
 156 isDict other        = False
 157
 158 isClassDict :: Inst -> Bool
 159 isClassDict (Dict _ pred _) = isClassPred pred
 160 isClassDict other           = False
 161
 162 isTyVarDict :: Inst -> Bool
 163 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 164 isTyVarDict other           = False
 165
 166 isIPDict :: Inst -> Bool
 167 isIPDict (Dict _ pred _) = isIPPred pred
 168 isIPDict other           = False
 169
 170 isMethod :: Inst -> Bool
 171 isMethod (Method _ _ _ _ _ _) = True
 172 isMethod other                = False
 173
 174 isMethodFor :: TcIdSet -> Inst -> Bool
 175 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 176 isMethodFor ids inst                         = False
 177
 178 isLinearInst :: Inst -> Bool
 179 isLinearInst (Dict _ pred _) = isLinearPred pred
 180 isLinearInst other           = False
 181         -- We never build Method Insts that have
 182         -- linear implicit paramters in them.
 183         -- Hence no need to look for Methods
 184         -- See TcExpr.tcId
 185
 186 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 187 linearInstType (Dict _ (IParam _ ty) _) = ty
 188
 189
 190 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 191                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 192                                         other             -> False
 193 \end{code}
 194
 195 Two predicates which deal with the case where class constraints don't
 196 necessarily result in bindings.  The first tells whether an @Inst@
 197 must be witnessed by an actual binding; the second tells whether an
 198 @Inst@ can be generalised over.
 199
 200 \begin{code}
 201 instBindingRequired :: Inst -> Bool
 202 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 203 instBindingRequired other                      = True
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Building dictionaries}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 newDicts :: InstOrigin
 215          -> TcThetaType
 216          -> TcM [Inst]
 217 newDicts orig theta
 218   = getInstLoc orig             `thenM` \ loc ->
 219     newDictsAtLoc loc theta
 220
 221 cloneDict :: Inst -> TcM Inst
 222 cloneDict (Dict id ty loc) = newUnique  `thenM` \ uniq ->
 223                              returnM (Dict (setIdUnique id uniq) ty loc)
 224
 225 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
 226 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 227
 228 -- Local function, similar to newDicts,
 229 -- but with slightly different interface
 230 newDictsAtLoc :: InstLoc
 231               -> TcThetaType
 232               -> TcM [Inst]
 233 newDictsAtLoc inst_loc theta
 234   = newUniqueSupply             `thenM` \ us ->
 235     returnM (zipWith mk_dict (uniqsFromSupply us) theta)
 236   where
 237     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
 238                              pred inst_loc
 239     loc = instLocSrcLoc inst_loc
 240
 241 -- For vanilla implicit parameters, there is only one in scope
 242 -- at any time, so we used to use the name of the implicit parameter itself
 243 -- But with splittable implicit parameters there may be many in
 244 -- scope, so we make up a new name.
 245 newIPDict :: InstOrigin -> IPName Name -> Type
 246           -> TcM (IPName Id, Inst)
 247 newIPDict orig ip_name ty
 248   = getInstLoc orig                     `thenM` \ inst_loc@(InstLoc _ loc _) ->
 249     newUnique                           `thenM` \ uniq ->
 250     let
 251         pred = IParam ip_name ty
 252         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 253     in
 254     returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 255 \end{code}
 256
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection{Building methods (calls of overloaded functions)}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265
 266 \begin{code}
 267 tcInstCall :: InstOrigin  -> TcType -> TcM (ExprCoFn, TcType)
 268 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
 269   = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
 270     newDicts orig theta         `thenM` \ dicts ->
 271     extendLIEs dicts            `thenM_`
 272     let
 273         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
 274     in
 275     returnM (mkCoercion inst_fn, tau)
 276
 277 tcInstDataCon :: InstOrigin -> DataCon
 278               -> TcM ([TcType], -- Types to instantiate at
 279                       [Inst],   -- Existential dictionaries to apply to
 280                       [TcType], -- Argument types of constructor
 281                       TcType,   -- Result type
 282                       [TyVar])  -- Existential tyvars
 283 tcInstDataCon orig data_con
 284   = let
 285         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 286              -- We generate constraints for the stupid theta even when
 287              -- pattern matching (as the Report requires)
 288     in
 289     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenM` \ (all_tvs', ty_args', tenv) ->
 290     let
 291         stupid_theta' = substTheta tenv stupid_theta
 292         ex_theta'     = substTheta tenv ex_theta
 293         arg_tys'      = map (substTy tenv) arg_tys
 294
 295         n_normal_tvs  = length tvs
 296         ex_tvs'       = drop n_normal_tvs all_tvs'
 297         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
 298     in
 299     newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
 300     newDicts orig ex_theta'     `thenM` \ ex_dicts ->
 301
 302         -- Note that we return the stupid theta *only* in the LIE;
 303         -- we don't otherwise use it at all
 304     extendLIEs stupid_dicts     `thenM_`
 305
 306     returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
 307
 308 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
 309 newMethodFromName origin ty name
 310   = tcLookupId name             `thenM` \ id ->
 311         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 312         -- always a class op, but with -fno-implicit-prelude GHC is
 313         -- meant to find whatever thing is in scope, and that may
 314         -- be an ordinary function.
 315     getInstLoc origin           `thenM` \ loc ->
 316     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 317     extendLIE inst              `thenM_`
 318     returnM (instToId inst)
 319
 320 newMethodWithGivenTy orig id tys theta tau
 321   = getInstLoc orig                     `thenM` \ loc ->
 322     newMethod loc id tys theta tau      `thenM` \ inst ->
 323     extendLIE inst                      `thenM_`
 324     returnM (instToId inst)
 325
 326 --------------------------------------------
 327 -- tcInstClassOp, and newMethod do *not* drop the
 328 -- Inst into the LIE; they just returns the Inst
 329 -- This is important because they are used by TcSimplify
 330 -- to simplify Insts
 331
 332 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 333 tcInstClassOp inst_loc sel_id tys
 334   = let
 335         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 336         rho_ty       = ASSERT( length tyvars == length tys )
 337                        substTyWith tyvars tys rho
 338         (preds,tau)  = tcSplitPhiTy rho_ty
 339     in
 340     newMethod inst_loc sel_id tys preds tau
 341
 342 ---------------------------
 343 newMethod inst_loc id tys theta tau
 344   = newUnique           `thenM` \ new_uniq ->
 345     let
 346         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 347         inst    = Method meth_id id tys theta tau inst_loc
 348         loc     = instLocSrcLoc inst_loc
 349     in
 350     returnM inst
 351 \end{code}
 352
 353 In newOverloadedLit we convert directly to an Int or Integer if we
 354 know that's what we want.  This may save some time, by not
 355 temporarily generating overloaded literals, but it won't catch all
 356 cases (the rest are caught in lookupInst).
 357
 358 \begin{code}
 359 newOverloadedLit :: InstOrigin
 360                  -> HsOverLit
 361                  -> TcType
 362                  -> TcM TcExpr
 363 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 364   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
 365                                 -- syntax.  Reason: tcSyntaxName does unification
 366                                 -- which is very inconvenient in tcSimplify
 367   = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi)   `thenM` \ (_,expr) ->
 368     mkIntegerLit i                                              `thenM` \ integer_lit ->
 369     returnM (HsApp expr integer_lit)
 370
 371   | Just expr <- shortCutIntLit i expected_ty
 372   = returnM expr
 373
 374   | otherwise
 375   = newLitInst orig lit expected_ty
 376
 377 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 378   | fr /= fromRationalName      -- c.f. HsIntegral case
 379   = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr)  `thenM` \ (_,expr) ->
 380     mkRatLit r                                                  `thenM` \ rat_lit ->
 381     returnM (HsApp expr rat_lit)
 382
 383   | Just expr <- shortCutFracLit r expected_ty
 384   = returnM expr
 385
 386   | otherwise
 387   = newLitInst orig lit expected_ty
 388
 389 newLitInst orig lit expected_ty
 390   = getInstLoc orig             `thenM` \ loc ->
 391     newUnique                   `thenM` \ new_uniq ->
 392     let
 393         lit_inst = LitInst lit_id lit expected_ty loc
 394         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 395     in
 396     extendLIE lit_inst          `thenM_`
 397     returnM (HsVar (instToId lit_inst))
 398
 399 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
 400 shortCutIntLit i ty
 401   | isIntTy ty && inIntRange i          -- Short cut for Int
 402   = Just (HsLit (HsInt i))
 403   | isIntegerTy ty                      -- Short cut for Integer
 404   = Just (HsLit (HsInteger i ty))
 405   | otherwise = Nothing
 406
 407 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
 408 shortCutFracLit f ty
 409   | isFloatTy ty
 410   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 411   | isDoubleTy ty
 412   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 413   | otherwise = Nothing
 414
 415 mkIntegerLit :: Integer -> TcM TcExpr
 416 mkIntegerLit i
 417   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 418     returnM (HsLit (HsInteger i integer_ty))
 419
 420 mkRatLit :: Rational -> TcM TcExpr
 421 mkRatLit r
 422   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 423     returnM (HsLit (HsRat r rat_ty))
 424 \end{code}
 425
 426
 427 %************************************************************************
 428 %*                                                                      *
 429 \subsection{Zonking}
 430 %*                                                                      *
 431 %************************************************************************
 432
 433 Zonking makes sure that the instance types are fully zonked,
 434 but doesn't do the same for any of the Ids in an Inst.  There's no
 435 need, and it's a lot of extra work.
 436
 437 \begin{code}
 438 zonkInst :: Inst -> TcM Inst
 439 zonkInst (Dict id pred loc)
 440   = zonkTcPredType pred                 `thenM` \ new_pred ->
 441     returnM (Dict id new_pred loc)
 442
 443 zonkInst (Method m id tys theta tau loc)
 444   = zonkId id                   `thenM` \ new_id ->
 445         -- Essential to zonk the id in case it's a local variable
 446         -- Can't use zonkIdOcc because the id might itself be
 447         -- an InstId, in which case it won't be in scope
 448
 449     zonkTcTypes tys             `thenM` \ new_tys ->
 450     zonkTcThetaType theta       `thenM` \ new_theta ->
 451     zonkTcType tau              `thenM` \ new_tau ->
 452     returnM (Method m new_id new_tys new_theta new_tau loc)
 453
 454 zonkInst (LitInst id lit ty loc)
 455   = zonkTcType ty                       `thenM` \ new_ty ->
 456     returnM (LitInst id lit new_ty loc)
 457
 458 zonkInsts insts = mappM zonkInst insts
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection{Printing}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 469 relevant in error messages.
 470
 471 \begin{code}
 472 instance Outputable Inst where
 473     ppr inst = pprInst inst
 474
 475 pprInsts :: [Inst] -> SDoc
 476 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 477
 478 pprInstsInFull insts
 479   = vcat (map go insts)
 480   where
 481     go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
 482
 483 pprInst (LitInst u lit ty loc)
 484   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 485
 486 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 487
 488 pprInst m@(Method u id tys theta tau loc)
 489   = hsep [ppr id, ptext SLIT("at"),
 490           brackets (sep (map pprParendType tys)) {- ,
 491           ptext SLIT("theta"), ppr theta,
 492           ptext SLIT("tau"), ppr tau
 493           show_uniq u,
 494           ppr (instToId m) -}]
 495
 496
 497 pprDFuns :: [DFunId] -> SDoc
 498 -- Prints the dfun as an instance declaration
 499 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
 500                         2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
 501                                                            pprClassPred clas tys])
 502                       | dfun <- dfuns
 503                       , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
 504         -- Print without the for-all, which the programmer doesn't write
 505
 506 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 507
 508 tidyInst :: TidyEnv -> Inst -> Inst
 509 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 510 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 511 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 512
 513 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 514 -- This function doesn't assume that the tyvars are in scope
 515 -- so it works like tidyOpenType, returning a TidyEnv
 516 tidyMoreInsts env insts
 517   = (env', map (tidyInst env') insts)
 518   where
 519     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 520
 521 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 522 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 523
 524 showLIE :: SDoc -> TcM ()       -- Debugging
 525 showLIE str
 526   = do { lie_var <- getLIEVar ;
 527          lie <- readMutVar lie_var ;
 528          traceTc (str <+> pprInstsInFull (lieToList lie)) }
 529 \end{code}
 530
 531
 532 %************************************************************************
 533 %*                                                                      *
 534         Extending the instance environment
 535 %*                                                                      *
 536 %************************************************************************
 537
 538 \begin{code}
 539 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 540   -- Add new locally-defined instances
 541 tcExtendLocalInstEnv dfuns thing_inside
 542  = do { traceDFuns dfuns
 543       ; env <- getGblEnv
 544       ; dflags  <- getDOpts
 545       ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
 546       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 547                          tcg_inst_env = inst_env' }
 548       ; setGblEnv env' thing_inside }
 549
 550 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 551 -- Check that the proposed new instance is OK,
 552 -- and then add it to the home inst env
 553 addInst dflags home_ie dfun
 554   = do  {       -- Load imported instances, so that we report
 555                 -- duplicates correctly
 556           pkg_ie  <- loadImportedInsts cls tys
 557
 558                 -- Check functional dependencies
 559         ; case checkFunDeps (pkg_ie, home_ie) dfun of
 560                 Just dfuns -> funDepErr dfun dfuns
 561                 Nothing    -> return ()
 562
 563                 -- Check for duplicate instance decls
 564         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
 565               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 566                                         isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
 567                 -- Find memebers of the match list which
 568                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 569         ; case dup_dfuns of
 570             dup_dfun : _ -> dupInstErr dfun dup_dfun
 571             []           -> return ()
 572
 573                 -- OK, now extend the envt
 574         ; return (extendInstEnv home_ie dfun) }
 575   where
 576     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 577
 578 traceDFuns dfuns
 579   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 580   where
 581     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 582
 583 funDepErr dfun dfuns
 584   = addSrcLoc (getSrcLoc dfun) $
 585     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 586                2 (pprDFuns (dfun:dfuns)))
 587 dupInstErr dfun dup_dfun
 588   = addSrcLoc (getSrcLoc dfun) $
 589     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 590                2 (pprDFuns [dfun, dup_dfun]))
 591 \end{code}
 592
 593 %************************************************************************
 594 %*                                                                      *
 595 \subsection{Looking up Insts}
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 data LookupInstResult s
 601   = NoInstance
 602   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 603   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 604
 605 lookupInst :: Inst -> TcM (LookupInstResult s)
 606 -- It's important that lookupInst does not put any new stuff into
 607 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 608 -- the LookupInstResult, where they can be further processed by tcSimplify
 609
 610
 611 -- Methods
 612
 613 lookupInst inst@(Method _ id tys theta _ loc)
 614   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 615     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 616
 617 -- Literals
 618
 619 -- Look for short cuts first: if the literal is *definitely* a
 620 -- int, integer, float or a double, generate the real thing here.
 621 -- This is essential  (see nofib/spectral/nucleic).
 622 -- [Same shortcut as in newOverloadedLit, but we
 623 --  may have done some unification by now]
 624
 625
 626 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 627   | Just expr <- shortCutIntLit i ty
 628   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 629                                         -- expr may be a constructor application
 630   | otherwise
 631   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 632     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 633     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 634     mkIntegerLit i                              `thenM` \ integer_lit ->
 635     returnM (GenInst [method_inst]
 636                      (HsApp (HsVar (instToId method_inst)) integer_lit))
 637
 638 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 639   | Just expr <- shortCutFracLit f ty
 640   = returnM (GenInst [] expr)
 641
 642   | otherwise
 643   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 644     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 645     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 646     mkRatLit f                                  `thenM` \ rat_lit ->
 647     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 648
 649 -- Dictionaries
 650 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 651   | all tcIsTyVarTy tys  -- Common special case; no lookup
 652                          -- NB: tcIsTyVarTy... don't look through newtypes!
 653   = returnM NoInstance
 654
 655   | otherwise
 656   = do  { pkg_ie  <- loadImportedInsts clas tys
 657                 -- Suck in any instance decls that may be relevant
 658         ; tcg_env <- getGblEnv
 659         ; dflags  <- getDOpts
 660         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 661             ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 662             (matches, unifs)              -> do
 663         { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
 664                                                text "unifs" <+> ppr unifs])
 665         ; return NoInstance } } }
 666                 -- In the case of overlap (multiple matches) we report
 667                 -- NoInstance here.  That has the effect of making the
 668                 -- context-simplifier return the dict as an irreducible one.
 669                 -- Then it'll be given to addNoInstanceErrs, which will do another
 670                 -- lookupInstEnv to get the detailed info about what went wrong.
 671
 672 lookupInst (Dict _ _ _) = returnM NoInstance
 673
 674 -----------------
 675 instantiate_dfun tenv dfun_id pred loc
 676   =     -- Record that this dfun is needed
 677     record_dfun_usage dfun_id           `thenM_`
 678
 679         -- It's possible that not all the tyvars are in
 680         -- the substitution, tenv. For example:
 681         --      instance C X a => D X where ...
 682         -- (presumably there's a functional dependency in class C)
 683         -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 684     getStage                                            `thenM` \ use_stage ->
 685     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 686                     (topIdLvl dfun_id) use_stage                `thenM_`
 687     let
 688         (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 689         mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 690                            Just (DoneTy ty) -> returnM ty
 691                            Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 692                                                returnM (mkTyVarTy tc_tv)
 693     in
 694     mappM mk_ty_arg tyvars      `thenM` \ ty_args ->
 695     let
 696         dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 697         (theta, _) = tcSplitPhiTy dfun_rho
 698         ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 699     in
 700     if null theta then
 701         returnM (SimpleInst ty_app)
 702     else
 703     newDictsAtLoc loc theta     `thenM` \ dicts ->
 704     let
 705         rhs = mkHsDictApp ty_app (map instToId dicts)
 706     in
 707     returnM (GenInst dicts rhs)
 708
 709 record_dfun_usage dfun_id
 710   | isInternalName dfun_name = return ()                -- From this module
 711   | not (isHomePackageName dfun_name) = return ()       -- From another package package
 712   | otherwise = getGblEnv       `thenM` \ tcg_env ->
 713                 updMutVar (tcg_inst_uses tcg_env)
 714                           (`addOneToNameSet` idName dfun_id)
 715   where
 716     dfun_name = idName dfun_id
 717
 718 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 719 -- Gets both the home-pkg inst env (includes module being compiled)
 720 -- and the external-package inst-env
 721 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 722                      return (tcg_inst_env env, eps_inst_env eps) }
 723 \end{code}
 724
 725
 726
 727 %************************************************************************
 728 %*                                                                      *
 729                 Re-mappable syntax
 730 %*                                                                      *
 731 %************************************************************************
 732
 733
 734 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 735 a do-expression.  We have to find (>>) in the current environment, which is
 736 done by the rename. Then we have to check that it has the same type as
 737 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 738 this:
 739
 740   (>>) :: HB m n mn => m a -> n b -> mn b
 741
 742 So the idea is to generate a local binding for (>>), thus:
 743
 744         let then72 :: forall a b. m a -> m b -> m b
 745             then72 = ...something involving the user's (>>)...
 746         in
 747         ...the do-expression...
 748
 749 Now the do-expression can proceed using then72, which has exactly
 750 the expected type.
 751
 752 In fact tcSyntaxName just generates the RHS for then72, because we only
 753 want an actual binding in the do-expression case. For literals, we can
 754 just use the expression inline.
 755
 756 \begin{code}
 757 tcSyntaxName :: InstOrigin
 758              -> TcType                  -- Type to instantiate it at
 759              -> (Name, HsExpr Name)     -- (Standard name, user name)
 760              -> TcM (Name, TcExpr)      -- (Standard name, suitable expression)
 761
 762 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 763 -- So we do not call it from lookupInst, which is called from tcSimplify
 764
 765 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 766   | std_nm == user_nm
 767   = tcStdSyntaxName orig ty std_nm
 768
 769 tcSyntaxName orig ty (std_nm, user_nm_expr)
 770   = tcLookupId std_nm           `thenM` \ std_id ->
 771     let
 772         -- C.f. newMethodAtLoc
 773         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 774         tau1            = substTyWith [tv] [ty] tau
 775         -- Actually, the "tau-type" might be a sigma-type in the
 776         -- case of locally-polymorphic methods.
 777     in
 778     addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
 779
 780         -- Check that the user-supplied thing has the
 781         -- same type as the standard one
 782     tcCheckSigma user_nm_expr tau1                      `thenM` \ expr ->
 783     returnM (std_nm, expr)
 784
 785 tcStdSyntaxName :: InstOrigin
 786                 -> TcType               -- Type to instantiate it at
 787                 -> Name                 -- Standard name
 788                 -> TcM (Name, TcExpr)   -- (Standard name, suitable expression)
 789
 790 tcStdSyntaxName orig ty std_nm
 791   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 792     returnM (std_nm, HsVar id)
 793
 794 syntaxNameCtxt name orig ty tidy_env
 795   = getInstLoc orig             `thenM` \ inst_loc ->
 796     let
 797         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 798                                 ptext SLIT("(needed by a syntactic construct)"),
 799                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 800                     nest 2 (pprInstLoc inst_loc)]
 801     in
 802     returnM (tidy_env, msg)
 803 \end{code}