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         newDicts, newDictAtLoc, 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(..), lookupPred,
  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 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
 232 newDictAtLoc inst_loc pred
 233   = do  { uniq <- newUnique
 234         ; return (mkDict inst_loc uniq pred) }
 235
 236 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
 237 newDictsAtLoc inst_loc theta
 238   = newUniqueSupply             `thenM` \ us ->
 239     returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
 240
 241 mkDict inst_loc uniq pred
 242   = Dict name pred inst_loc
 243   where
 244     name = mkPredName uniq (instLocSrcLoc inst_loc) pred
 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   = mkSystemVarNameEncoded 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  {       -- Instantiate the dfun type so that we extend the instance
 570                 -- envt with completely fresh template variables
 571                 -- This is important because the template variables must
 572                 -- not overlap with anything in the things being looked up
 573                 -- (since we do unification).
 574                 -- We use tcSkolType because we don't want to allocate fresh
 575                 -- *meta* type variables.
 576           (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
 577         ; let   (cls, tys') = tcSplitDFunHead tau'
 578                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 579
 580                 -- Load imported instances, so that we report
 581                 -- duplicates correctly
 582         ; pkg_ie  <- loadImportedInsts cls tys'
 583
 584                 -- Check functional dependencies
 585         ; case checkFunDeps (pkg_ie, home_ie) dfun' of
 586                 Just dfuns -> funDepErr dfun dfuns
 587                 Nothing    -> return ()
 588
 589                 -- Check for duplicate instance decls
 590         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
 591               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 592                                         isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 593                 -- Find memebers of the match list which
 594                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 595         ; case dup_dfuns of
 596             dup_dfun : _ -> dupInstErr dfun dup_dfun
 597             []           -> return ()
 598
 599                 -- OK, now extend the envt
 600         ; return (extendInstEnv home_ie dfun') }
 601
 602
 603 traceDFuns dfuns
 604   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 605   where
 606     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 607
 608 funDepErr dfun dfuns
 609   = addDictLoc dfun $
 610     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 611                2 (pprDFuns (dfun:dfuns)))
 612 dupInstErr dfun dup_dfun
 613   = addDictLoc dfun $
 614     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 615                2 (pprDFuns [dfun, dup_dfun]))
 616
 617 addDictLoc dfun thing_inside
 618   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 619   where
 620    loc = getSrcLoc dfun
 621 \end{code}
 622
 623
 624 %************************************************************************
 625 %*                                                                      *
 626 \subsection{Looking up Insts}
 627 %*                                                                      *
 628 %************************************************************************
 629
 630 \begin{code}
 631 data LookupInstResult
 632   = NoInstance
 633   | SimpleInst (LHsExpr TcId)           -- Just a variable, type application, or literal
 634   | GenInst    [Inst] (LHsExpr TcId)    -- The expression and its needed insts
 635
 636 lookupInst :: Inst -> TcM LookupInstResult
 637 -- It's important that lookupInst does not put any new stuff into
 638 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 639 -- the LookupInstResult, where they can be further processed by tcSimplify
 640
 641
 642 -- Methods
 643
 644 lookupInst inst@(Method _ id tys theta _ loc)
 645   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 646     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
 647   where
 648     span = instLocSrcSpan loc
 649
 650 -- Literals
 651
 652 -- Look for short cuts first: if the literal is *definitely* a
 653 -- int, integer, float or a double, generate the real thing here.
 654 -- This is essential  (see nofib/spectral/nucleic).
 655 -- [Same shortcut as in newOverloadedLit, but we
 656 --  may have done some unification by now]
 657
 658
 659 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
 660   | Just expr <- shortCutIntLit i ty
 661   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 662                                         -- expr may be a constructor application
 663   | otherwise
 664   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 665     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 666     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 667     mkIntegerLit i                              `thenM` \ integer_lit ->
 668     returnM (GenInst [method_inst]
 669                      (mkHsApp (L (instLocSrcSpan loc)
 670                                  (HsVar (instToId method_inst))) integer_lit))
 671
 672 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
 673   | Just expr <- shortCutFracLit f ty
 674   = returnM (GenInst [] expr)
 675
 676   | otherwise
 677   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 678     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 679     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 680     mkRatLit f                                  `thenM` \ rat_lit ->
 681     returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
 682                                                (HsVar (instToId method_inst))) rat_lit))
 683
 684 -- Dictionaries
 685 lookupInst (Dict _ pred loc)
 686   = do  { mb_result <- lookupPred pred
 687         ; case mb_result of {
 688             Nothing -> return NoInstance ;
 689             Just (tenv, dfun_id) -> do
 690
 691     -- tenv is a substitution that instantiates the dfun_id
 692     -- to match the requested result type.
 693     --
 694     -- We ASSUME that the dfun is quantified over the very same tyvars
 695     -- that are bound by the tenv.
 696     --
 697     -- However, the dfun
 698     -- might have some tyvars that *only* appear in arguments
 699     --  dfun :: forall a b. C a b, Ord b => D [a]
 700     -- We instantiate b to a flexi type variable -- it'll presumably
 701     -- become fixed later via functional dependencies
 702     { use_stage <- getStage
 703     ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 704                       (topIdLvl dfun_id) use_stage
 705
 706         -- It's possible that not all the tyvars are in
 707         -- the substitution, tenv. For example:
 708         --      instance C X a => D X where ...
 709         -- (presumably there's a functional dependency in class C)
 710         -- Hence the open_tvs to instantiate any un-substituted tyvars.
 711     ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 712           open_tvs      = filter (`notElemTvSubst` tenv) tyvars
 713     ; open_tvs' <- mappM tcInstTyVar open_tvs
 714     ; let
 715         tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
 716                 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
 717                 -- any nested for-alls in rho.  So the in-scope set is unchanged
 718         dfun_rho   = substTy tenv' rho
 719         (theta, _) = tcSplitPhiTy dfun_rho
 720         ty_app     = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
 721                                (map (substTyVar tenv') tyvars)
 722     ; if null theta then
 723         returnM (SimpleInst ty_app)
 724       else do
 725     { dicts <- newDictsAtLoc loc theta
 726     ; let rhs = mkHsDictApp ty_app (map instToId dicts)
 727     ; returnM (GenInst dicts rhs)
 728     }}}}
 729
 730 ---------------
 731 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
 732 -- Look up a class constraint in the instance environment
 733 lookupPred pred@(ClassP clas tys)
 734   = do  { pkg_ie <- loadImportedInsts clas tys
 735                 -- Suck in any instance decls that may be relevant
 736         ; tcg_env <- getGblEnv
 737         ; dflags  <- getDOpts
 738         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 739             ([(tenv, (_,_,dfun_id))], [])
 740                 -> do   { traceTc (text "lookupInst success" <+>
 741                                    vcat [text "dict" <+> ppr pred,
 742                                          text "witness" <+> ppr dfun_id
 743                                          <+> ppr (idType dfun_id) ])
 744                                 -- Record that this dfun is needed
 745                         ; record_dfun_usage dfun_id
 746                         ; return (Just (tenv, dfun_id)) } ;
 747
 748             (matches, unifs)
 749                 -> do   { traceTc (text "lookupInst fail" <+>
 750                                    vcat [text "dict" <+> ppr pred,
 751                                          text "matches" <+> ppr matches,
 752                                          text "unifs" <+> ppr unifs])
 753                 -- In the case of overlap (multiple matches) we report
 754                 -- NoInstance here.  That has the effect of making the
 755                 -- context-simplifier return the dict as an irreducible one.
 756                 -- Then it'll be given to addNoInstanceErrs, which will do another
 757                 -- lookupInstEnv to get the detailed info about what went wrong.
 758                         ; return Nothing }
 759         }}
 760
 761 lookupPred ip_pred = return Nothing
 762
 763 record_dfun_usage dfun_id
 764   = do  { dflags <- getDOpts
 765         ; let  dfun_name = idName dfun_id
 766                dfun_mod  = nameModule dfun_name
 767         ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
 768           then return () -- internal, or in another package
 769            else do { tcg_env <- getGblEnv
 770                    ; updMutVar (tcg_inst_uses tcg_env)
 771                                (`addOneToNameSet` idName dfun_id) }}
 772
 773
 774 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 775 -- Gets both the external-package inst-env
 776 -- and the home-pkg inst env (includes module being compiled)
 777 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 778                      return (eps_inst_env eps, tcg_inst_env env) }
 779 \end{code}
 780
 781
 782
 783 %************************************************************************
 784 %*                                                                      *
 785                 Re-mappable syntax
 786 %*                                                                      *
 787 %************************************************************************
 788
 789
 790 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 791 a do-expression.  We have to find (>>) in the current environment, which is
 792 done by the rename. Then we have to check that it has the same type as
 793 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 794 this:
 795
 796   (>>) :: HB m n mn => m a -> n b -> mn b
 797
 798 So the idea is to generate a local binding for (>>), thus:
 799
 800         let then72 :: forall a b. m a -> m b -> m b
 801             then72 = ...something involving the user's (>>)...
 802         in
 803         ...the do-expression...
 804
 805 Now the do-expression can proceed using then72, which has exactly
 806 the expected type.
 807
 808 In fact tcSyntaxName just generates the RHS for then72, because we only
 809 want an actual binding in the do-expression case. For literals, we can
 810 just use the expression inline.
 811
 812 \begin{code}
 813 tcSyntaxName :: InstOrigin
 814              -> TcType                  -- Type to instantiate it at
 815              -> (Name, HsExpr Name)     -- (Standard name, user name)
 816              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 817
 818 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 819 -- So we do not call it from lookupInst, which is called from tcSimplify
 820
 821 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 822   | std_nm == user_nm
 823   = tcStdSyntaxName orig ty std_nm
 824
 825 tcSyntaxName orig ty (std_nm, user_nm_expr)
 826   = tcLookupId std_nm           `thenM` \ std_id ->
 827     let
 828         -- C.f. newMethodAtLoc
 829         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 830         sigma1          = substTyWith [tv] [ty] tau
 831         -- Actually, the "tau-type" might be a sigma-type in the
 832         -- case of locally-polymorphic methods.
 833     in
 834     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)       $
 835
 836         -- Check that the user-supplied thing has the
 837         -- same type as the standard one.
 838         -- Tiresome jiggling because tcCheckSigma takes a located expression
 839     getSrcSpanM                                 `thenM` \ span ->
 840     tcCheckSigma (L span user_nm_expr) sigma1   `thenM` \ expr ->
 841     returnM (std_nm, unLoc expr)
 842
 843 tcStdSyntaxName :: InstOrigin
 844                 -> TcType                       -- Type to instantiate it at
 845                 -> Name                         -- Standard name
 846                 -> TcM (Name, HsExpr TcId)      -- (Standard name, suitable expression)
 847
 848 tcStdSyntaxName orig ty std_nm
 849   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 850     returnM (std_nm, HsVar id)
 851
 852 syntaxNameCtxt name orig ty tidy_env
 853   = getInstLoc orig             `thenM` \ inst_loc ->
 854     let
 855         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 856                                 ptext SLIT("(needed by a syntactic construct)"),
 857                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 858                     nest 2 (pprInstLoc inst_loc)]
 859     in
 860     returnM (tidy_env, msg)
 861 \end{code}