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