compiler/typecheck/Inst.lhs

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