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