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