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