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