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, mkOverLit,
  20         newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
  21         tcInstClassOp,
  22         tcSyntaxName, isHsVar,
  23
  24         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  25         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  26         getDictClassTys, dictPred,
  27
  28         lookupSimpleInst, LookupInstResult(..),
  29         tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
  30
  31         isAbstractableInst, isEqInst,
  32         isDict, isClassDict, isMethod, isImplicInst,
  33         isIPDict, isInheritableInst, isMethodOrLit,
  34         isTyVarDict, isMethodFor,
  35
  36         zonkInst, zonkInsts,
  37         instToId, instToVar, instType, instName, instToDictBind,
  38         addInstToDictBind,
  39
  40         InstOrigin(..), InstLoc, pprInstLoc,
  41
  42         mkWantedCo, mkGivenCo,
  43         fromWantedCo, fromGivenCo,
  44         eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
  45         finalizeEqInst, writeWantedCoercion,
  46         eqInstType, updateEqInstCoercion,
  47         eqInstCoercion, eqInstTys
  48     ) where
  49
  50 #include "HsVersions.h"
  51
  52 import {-# SOURCE #-}   TcExpr( tcPolyExpr )
  53 import {-# SOURCE #-}   TcUnify( boxyUnify {- , unifyType -} )
  54
  55 import FastString
  56 import HsSyn
  57 import TcHsSyn
  58 import TcRnMonad
  59 import TcEnv
  60 import InstEnv
  61 import FunDeps
  62 import TcMType
  63 import TcType
  64 import DsUtils
  65 import Type
  66 import TypeRep
  67 import Class
  68 import Unify
  69 import Module
  70 import Coercion
  71 import HscTypes
  72 import CoreFVs
  73 import Id
  74 import Name
  75 import NameSet
  76 import Var      ( Var, TyVar )
  77 import qualified Var
  78 import VarEnv
  79 import VarSet
  80 import PrelNames
  81 import BasicTypes
  82 import SrcLoc
  83 import DynFlags
  84 import Bag
  85 import Maybes
  86 import Util
  87 import Unique
  88 import Outputable
  89 import Data.List
  90
  91 import Control.Monad
  92 \end{code}
  93
  94
  95 Selection
  96 ~~~~~~~~~
  97 \begin{code}
  98 instName :: Inst -> Name
  99 instName (EqInst {tci_name = name}) = name
 100 instName inst = Var.varName (instToVar inst)
 101
 102 instToId :: Inst -> TcId
 103 instToId inst = WARN( not (isId id), ppr inst )
 104               id
 105               where
 106                 id = instToVar inst
 107
 108 instToVar :: Inst -> Var
 109 instToVar (LitInst {tci_name = nm, tci_ty = ty})
 110   = mkLocalId nm ty
 111 instToVar (Method {tci_id = id})
 112   = id
 113 instToVar (Dict {tci_name = nm, tci_pred = pred})
 114   | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
 115   | otherwise     = mkLocalId nm (mkPredTy pred)
 116 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
 117                        tci_wanted = wanteds})
 118   = mkLocalId nm (mkImplicTy tvs givens wanteds)
 119 instToVar i@(EqInst {})
 120   = eitherEqInst i id (\(TyVarTy covar) -> covar)
 121
 122 instType :: Inst -> Type
 123 instType (LitInst {tci_ty = ty})  = ty
 124 instType (Method {tci_id = id})   = idType id
 125 instType (Dict {tci_pred = pred}) = mkPredTy pred
 126 instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 127                                                (tci_wanted imp)
 128 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
 129 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
 130
 131 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
 132 mkImplicTy tvs givens wanteds   -- The type of an implication constraint
 133   = ASSERT( all isAbstractableInst givens )
 134     -- pprTrace "mkImplicTy" (ppr givens) $
 135     -- See [Equational Constraints in Implication Constraints]
 136     let dict_wanteds = filter (not . isEqInst) wanteds
 137     in
 138       mkForAllTys tvs $
 139       mkPhiTy (map dictPred givens) $
 140       mkBigCoreTupTy (map instType dict_wanteds)
 141
 142 dictPred :: Inst -> TcPredType
 143 dictPred (Dict {tci_pred = pred}) = pred
 144 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
 145 dictPred inst                     = pprPanic "dictPred" (ppr inst)
 146
 147 getDictClassTys :: Inst -> (Class, [Type])
 148 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
 149 getDictClassTys inst                     = pprPanic "getDictClassTys" (ppr inst)
 150
 151 -- fdPredsOfInst is used to get predicates that contain functional
 152 -- dependencies *or* might do so.  The "might do" part is because
 153 -- a constraint (C a b) might have a superclass with FDs
 154 -- Leaving these in is really important for the call to fdPredsOfInsts
 155 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 156 -- which is supposed to be conservative
 157 fdPredsOfInst :: Inst -> [TcPredType]
 158 fdPredsOfInst (Dict {tci_pred = pred})       = [pred]
 159 fdPredsOfInst (Method {tci_theta = theta})   = theta
 160 fdPredsOfInst (ImplicInst {tci_given = gs,
 161                            tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
 162 fdPredsOfInst (LitInst {})                   = []
 163 fdPredsOfInst (EqInst {})                    = []
 164
 165 fdPredsOfInsts :: [Inst] -> [PredType]
 166 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 167
 168 isInheritableInst :: Inst -> Bool
 169 isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
 170 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
 171 isInheritableInst _                            = True
 172
 173
 174 ---------------------------------
 175 -- Get the implicit parameters mentioned by these Insts
 176 -- NB: the results of these functions are insensitive to zonking
 177
 178 ipNamesOfInsts :: [Inst] -> [Name]
 179 ipNamesOfInst  :: Inst   -> [Name]
 180 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 181
 182 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
 183 ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
 184 ipNamesOfInst _                              = []
 185
 186 ---------------------------------
 187 tyVarsOfInst :: Inst -> TcTyVarSet
 188 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 189 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
 190 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
 191                                  -- The id might have free type variables; in the case of
 192                                  -- locally-overloaded class methods, for example
 193 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
 194   = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
 195     `minusVarSet` mkVarSet tvs
 196     `unionVarSet` unionVarSets (map varTypeTyVars tvs)
 197                 -- Remember the free tyvars of a coercion
 198 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
 199
 200 tyVarsOfInsts :: [Inst] -> VarSet
 201 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 202 tyVarsOfLIE :: Bag Inst -> VarSet
 203 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 204
 205
 206 --------------------------
 207 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
 208 instToDictBind inst rhs
 209   = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
 210
 211 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
 212 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
 213 \end{code}
 214
 215 Predicates
 216 ~~~~~~~~~~
 217 \begin{code}
 218
 219 isAbstractableInst :: Inst -> Bool
 220 isAbstractableInst inst = isDict inst || isEqInst inst
 221
 222 isEqInst :: Inst -> Bool
 223 isEqInst (EqInst {}) = True
 224 isEqInst _           = False
 225
 226 isDict :: Inst -> Bool
 227 isDict (Dict {}) = True
 228 isDict _         = False
 229
 230 isClassDict :: Inst -> Bool
 231 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
 232 isClassDict _                        = False
 233
 234 isTyVarDict :: Inst -> Bool
 235 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
 236 isTyVarDict _                        = False
 237
 238 isIPDict :: Inst -> Bool
 239 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
 240 isIPDict _                        = False
 241
 242 isImplicInst :: Inst -> Bool
 243 isImplicInst (ImplicInst {}) = True
 244 isImplicInst _               = False
 245
 246 isMethod :: Inst -> Bool
 247 isMethod (Method {}) = True
 248 isMethod _           = False
 249
 250 isMethodFor :: TcIdSet -> Inst -> Bool
 251 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
 252 isMethodFor _   _                       = False
 253
 254 isMethodOrLit :: Inst -> Bool
 255 isMethodOrLit (Method {})  = True
 256 isMethodOrLit (LitInst {}) = True
 257 isMethodOrLit _            = False
 258 \end{code}
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection{Building dictionaries}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 -- newDictBndrs makes a dictionary at a binding site
 268 -- instCall makes a dictionary at an occurrence site
 269 --      and throws it into the LIE
 270
 271 \begin{code}
 272 ----------------
 273 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 274 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 275                               ; newDictBndrs loc theta }
 276
 277 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 278 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 279
 280 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 281 newDictBndr inst_loc pred@(EqPred ty1 ty2)
 282   = do { uniq <- newUnique
 283         ; let name = mkPredName uniq inst_loc pred
 284         ; return (EqInst {tci_name  = name,
 285                           tci_loc   = inst_loc,
 286                           tci_left  = ty1,
 287                           tci_right = ty2,
 288                           tci_co    = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
 289        }
 290 newDictBndr inst_loc pred
 291   = do  { uniq <- newUnique
 292         ; let name = mkPredName uniq inst_loc pred
 293         ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
 294
 295 ----------------
 296 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 297 -- Instantiate the constraints of a call
 298 --      (instCall o tys theta)
 299 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 300 -- (b) Throws these dictionaries into the LIE
 301 -- (c) Returns an HsWrapper ([.] tys dicts)
 302
 303 instCall orig tys theta
 304   = do  { loc <- getInstLoc orig
 305         ; dict_app <- instCallDicts loc theta
 306         ; return (dict_app <.> mkWpTyApps tys) }
 307
 308 ----------------
 309 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 310 -- Similar to instCall, but only emit the constraints in the LIE
 311 -- Used exclusively for the 'stupid theta' of a data constructor
 312 instStupidTheta orig theta
 313   = do  { loc <- getInstLoc orig
 314         ; _co <- instCallDicts loc theta        -- Discard the coercion
 315         ; return () }
 316
 317 ----------------
 318 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
 319 -- Instantiates the TcTheta, puts all constraints thereby generated
 320 -- into the LIE, and returns a HsWrapper to enclose the call site.
 321 -- This is the key place where equality predicates
 322 -- are unleashed into the world
 323 instCallDicts _ [] = return idHsWrapper
 324
 325 -- instCallDicts loc (EqPred ty1 ty2 : preds)
 326 --   = do  { unifyType ty1 ty2  -- For now, we insist that they unify right away
 327 --                              -- Later on, when we do associated types,
 328 --                              -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
 329 --      ; (dicts, co_fn) <- instCallDicts loc preds
 330 --      ; return (dicts, co_fn <.> WpTyApp ty1) }
 331 --      -- We use type application to apply the function to the
 332 --      -- coercion; here ty1 *is* the appropriate identity coercion
 333
 334 instCallDicts loc (EqPred ty1 ty2 : preds)
 335   = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
 336         ; coi <- boxyUnify ty1 ty2
 337 --      ; coi <- unifyType ty1 ty2
 338         ; let co = fromCoI coi ty1
 339         ; co_fn <- instCallDicts loc preds
 340         ; return (co_fn <.> WpTyApp co) }
 341
 342 instCallDicts loc (pred : preds)
 343   = do  { uniq <- newUnique
 344         ; let name = mkPredName uniq loc pred
 345               dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
 346         ; extendLIE dict
 347         ; co_fn <- instCallDicts loc preds
 348         ; return (co_fn <.> WpApp (instToId dict)) }
 349
 350 -------------
 351 cloneDict :: Inst -> TcM Inst
 352 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
 353                                      ; return (dict {tci_name = setNameUnique nm uniq}) }
 354 cloneDict eq@(EqInst {})        = return eq
 355 cloneDict other = pprPanic "cloneDict" (ppr other)
 356
 357 -- For vanilla implicit parameters, there is only one in scope
 358 -- at any time, so we used to use the name of the implicit parameter itself
 359 -- But with splittable implicit parameters there may be many in
 360 -- scope, so we make up a new namea.
 361 newIPDict :: InstOrigin -> IPName Name -> Type
 362           -> TcM (IPName Id, Inst)
 363 newIPDict orig ip_name ty = do
 364     inst_loc <- getInstLoc orig
 365     uniq <- newUnique
 366     let
 367         pred = IParam ip_name ty
 368         name = mkPredName uniq inst_loc pred
 369         dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
 370
 371     return (mapIPName (\_ -> instToId dict) ip_name, dict)
 372 \end{code}
 373
 374
 375 \begin{code}
 376 mkPredName :: Unique -> InstLoc -> PredType -> Name
 377 mkPredName uniq loc pred_ty
 378   = mkInternalName uniq occ (instLocSpan loc)
 379   where
 380     occ = case pred_ty of
 381             ClassP cls _ -> mkDictOcc (getOccName cls)
 382             IParam ip  _ -> getOccName (ipNameName ip)
 383             EqPred ty  _ -> mkEqPredCoOcc baseOcc
 384               where
 385                 -- we use the outermost tycon of the lhs, if there is one, to
 386                 -- improve readability of Core code
 387                 baseOcc = case splitTyConApp_maybe ty of
 388                             Nothing      -> mkOccName tcName "$"
 389                             Just (tc, _) -> getOccName tc
 390 \end{code}
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection{Building methods (calls of overloaded functions)}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398
 399 \begin{code}
 400 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 401 newMethodFromName origin ty name = do
 402     id <- tcLookupId name
 403         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 404         -- always a class op, but with -XNoImplicitPrelude GHC is
 405         -- meant to find whatever thing is in scope, and that may
 406         -- be an ordinary function.
 407     loc <- getInstLoc origin
 408     inst <- tcInstClassOp loc id [ty]
 409     extendLIE inst
 410     return (instToId inst)
 411
 412 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
 413 newMethodWithGivenTy orig id tys = do
 414     loc <- getInstLoc orig
 415     inst <- newMethod loc id tys
 416     extendLIE inst
 417     return (instToId inst)
 418
 419 --------------------------------------------
 420 -- tcInstClassOp, and newMethod do *not* drop the
 421 -- Inst into the LIE; they just returns the Inst
 422 -- This is important because they are used by TcSimplify
 423 -- to simplify Insts
 424
 425 -- NB: the kind of the type variable to be instantiated
 426 --     might be a sub-kind of the type to which it is applied,
 427 --     notably when the latter is a type variable of kind ??
 428 --     Hence the call to checkKind
 429 -- A worry: is this needed anywhere else?
 430 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 431 tcInstClassOp inst_loc sel_id tys = do
 432     let
 433         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 434     zipWithM_ checkKind tyvars tys
 435     newMethod inst_loc sel_id tys
 436
 437 checkKind :: TyVar -> TcType -> TcM ()
 438 -- Ensure that the type has a sub-kind of the tyvar
 439 checkKind tv ty
 440   = do  { let ty1 = ty
 441                 -- ty1 <- zonkTcType ty
 442         ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
 443           then return ()
 444           else
 445
 446     pprPanic "checkKind: adding kind constraint"
 447              (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
 448                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 449         }
 450 --    do        { tv1 <- tcInstTyVar tv
 451 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 452
 453
 454 ---------------------------
 455 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
 456 newMethod inst_loc id tys = do
 457     new_uniq <- newUnique
 458     let
 459         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 460         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 461         inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
 462                               tci_theta = theta, tci_loc = inst_loc}
 463         loc         = instLocSpan inst_loc
 464
 465     return inst
 466 \end{code}
 467
 468 \begin{code}
 469 mkOverLit :: OverLitVal -> TcM HsLit
 470 mkOverLit (HsIntegral i)
 471   = do  { integer_ty <- tcMetaTy integerTyConName
 472         ; return (HsInteger i integer_ty) }
 473
 474 mkOverLit (HsFractional r)
 475   = do  { rat_ty <- tcMetaTy rationalTyConName
 476         ; return (HsRat r rat_ty) }
 477
 478 mkOverLit (HsIsString s) = return (HsString s)
 479
 480 isHsVar :: HsExpr Name -> Name -> Bool
 481 isHsVar (HsVar f) g = f == g
 482 isHsVar _         _ = False
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{Zonking}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 Zonking makes sure that the instance types are fully zonked.
 493
 494 \begin{code}
 495 zonkInst :: Inst -> TcM Inst
 496 zonkInst dict@(Dict { tci_pred = pred}) = do
 497     new_pred <- zonkTcPredType pred
 498     return (dict {tci_pred = new_pred})
 499
 500 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
 501     new_id <- zonkId id
 502         -- Essential to zonk the id in case it's a local variable
 503         -- Can't use zonkIdOcc because the id might itself be
 504         -- an InstId, in which case it won't be in scope
 505
 506     new_tys <- zonkTcTypes tys
 507     new_theta <- zonkTcThetaType theta
 508     return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
 509         -- No need to zonk the tci_id
 510
 511 zonkInst lit@(LitInst {tci_ty = ty}) = do
 512     new_ty <- zonkTcType ty
 513     return (lit {tci_ty = new_ty})
 514
 515 zonkInst implic@(ImplicInst {})
 516   = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
 517     do  { givens'  <- zonkInsts (tci_given  implic)
 518         ; wanteds' <- zonkInsts (tci_wanted implic)
 519         ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
 520
 521 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
 522   = do { co' <- eitherEqInst eqinst
 523                   (\covar -> return (mkWantedCo covar))
 524                   (\co    -> liftM mkGivenCo $ zonkTcType co)
 525        ; ty1' <- zonkTcType ty1
 526        ; ty2' <- zonkTcType ty2
 527        ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
 528        }
 529
 530 zonkInsts :: [Inst] -> TcRn [Inst]
 531 zonkInsts insts = mapM zonkInst insts
 532 \end{code}
 533
 534
 535 %************************************************************************
 536 %*                                                                      *
 537 \subsection{Printing}
 538 %*                                                                      *
 539 %************************************************************************
 540
 541 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 542 relevant in error messages.
 543
 544 \begin{code}
 545 instance Outputable Inst where
 546     ppr inst = pprInst inst
 547
 548 pprDictsTheta :: [Inst] -> SDoc
 549 -- Print in type-like fashion (Eq a, Show b)
 550 -- The Inst can be an implication constraint, but not a Method or LitInst
 551 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
 552
 553 pprDictsInFull :: [Inst] -> SDoc
 554 -- Print in type-like fashion, but with source location
 555 pprDictsInFull dicts
 556   = vcat (map go dicts)
 557   where
 558     go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
 559
 560 pprInsts :: [Inst] -> SDoc
 561 -- Debugging: print the evidence :: type
 562 pprInsts insts = brackets (interpp'SP insts)
 563
 564 pprInst, pprInstInFull :: Inst -> SDoc
 565 -- Debugging: print the evidence :: type
 566 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
 567         = eitherEqInst i
 568                 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
 569                 (\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
 570 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
 571                 <+> braces (ppr (instType inst) <> implicWantedEqs)
 572   where
 573     name = instName inst
 574     implicWantedEqs
 575       | isImplicInst inst = text " &" <+>
 576                             ppr (filter isEqInst (tci_wanted inst))
 577       | otherwise         = empty
 578
 579 pprInstInFull inst@(EqInst {}) = pprInst inst
 580 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
 581
 582 tidyInst :: TidyEnv -> Inst -> Inst
 583 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
 584   eq { tci_left  = tidyType env lty
 585      , tci_right = tidyType env rty
 586      , tci_co    = either Left (Right . tidyType env) co
 587      }
 588 tidyInst env lit@(LitInst {tci_ty = ty})   = lit {tci_ty = tidyType env ty}
 589 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
 590 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
 591 tidyInst env implic@(ImplicInst {})
 592   = implic { tci_tyvars = tvs'
 593            , tci_given  = map (tidyInst env') (tci_given  implic)
 594            , tci_wanted = map (tidyInst env') (tci_wanted implic) }
 595   where
 596     (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
 597
 598 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 599 -- This function doesn't assume that the tyvars are in scope
 600 -- so it works like tidyOpenType, returning a TidyEnv
 601 tidyMoreInsts env insts
 602   = (env', map (tidyInst env') insts)
 603   where
 604     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 605
 606 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 607 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 608
 609 showLIE :: SDoc -> TcM ()       -- Debugging
 610 showLIE str
 611   = do { lie_var <- getLIEVar ;
 612          lie <- readMutVar lie_var ;
 613          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619         Extending the instance environment
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 625   -- Add new locally-defined instances
 626 tcExtendLocalInstEnv dfuns thing_inside
 627  = do { traceDFuns dfuns
 628       ; env <- getGblEnv
 629       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
 630       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 631                          tcg_inst_env = inst_env' }
 632       ; setGblEnv env' thing_inside }
 633
 634 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 635 -- Check that the proposed new instance is OK,
 636 -- and then add it to the home inst env
 637 addLocalInst home_ie ispec
 638   = do  {       -- Instantiate the dfun type so that we extend the instance
 639                 -- envt with completely fresh template variables
 640                 -- This is important because the template variables must
 641                 -- not overlap with anything in the things being looked up
 642                 -- (since we do unification).
 643                 -- We use tcInstSkolType because we don't want to allocate fresh
 644                 --  *meta* type variables.
 645           let dfun = instanceDFunId ispec
 646         ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
 647         ; let   (cls, tys') = tcSplitDFunHead tau'
 648                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 649                 ispec'      = setInstanceDFunId ispec dfun'
 650
 651                 -- Load imported instances, so that we report
 652                 -- duplicates correctly
 653         ; eps <- getEps
 654         ; let inst_envs = (eps_inst_env eps, home_ie)
 655
 656                 -- Check functional dependencies
 657         ; case checkFunDeps inst_envs ispec' of
 658                 Just specs -> funDepErr ispec' specs
 659                 Nothing    -> return ()
 660
 661                 -- Check for duplicate instance decls
 662         ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
 663               ; dup_ispecs = [ dup_ispec
 664                              | (dup_ispec, _) <- matches
 665                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
 666                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 667                 -- Find memebers of the match list which ispec itself matches.
 668                 -- If the match is 2-way, it's a duplicate
 669         ; case dup_ispecs of
 670             dup_ispec : _ -> dupInstErr ispec' dup_ispec
 671             []            -> return ()
 672
 673                 -- OK, now extend the envt
 674         ; return (extendInstEnv home_ie ispec') }
 675
 676 getOverlapFlag :: TcM OverlapFlag
 677 getOverlapFlag
 678   = do  { dflags <- getDOpts
 679         ; let overlap_ok    = dopt Opt_OverlappingInstances dflags
 680               incoherent_ok = dopt Opt_IncoherentInstances  dflags
 681               overlap_flag | incoherent_ok = Incoherent
 682                            | overlap_ok    = OverlapOk
 683                            | otherwise     = NoOverlap
 684
 685         ; return overlap_flag }
 686
 687 traceDFuns :: [Instance] -> TcRn ()
 688 traceDFuns ispecs
 689   = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
 690   where
 691     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 692         -- Print the dfun name itself too
 693
 694 funDepErr :: Instance -> [Instance] -> TcRn ()
 695 funDepErr ispec ispecs
 696   = addDictLoc ispec $
 697     addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
 698                2 (pprInstances (ispec:ispecs)))
 699 dupInstErr :: Instance -> Instance -> TcRn ()
 700 dupInstErr ispec dup_ispec
 701   = addDictLoc ispec $
 702     addErr (hang (ptext (sLit "Duplicate instance declarations:"))
 703                2 (pprInstances [ispec, dup_ispec]))
 704
 705 addDictLoc :: Instance -> TcRn a -> TcRn a
 706 addDictLoc ispec thing_inside
 707   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 708   where
 709    loc = getSrcLoc ispec
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection{Looking up Insts}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 \begin{code}
 720 data LookupInstResult
 721   = NoInstance
 722   | GenInst [Inst] (LHsExpr TcId)       -- The expression and its needed insts
 723
 724 lookupSimpleInst :: Inst -> TcM LookupInstResult
 725 -- This is "simple" in that it returns NoInstance for implication constraints
 726
 727 -- It's important that lookupInst does not put any new stuff into
 728 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 729 -- the LookupInstResult, where they can be further processed by tcSimplify
 730
 731 lookupSimpleInst (EqInst {}) = return NoInstance
 732
 733 --------------------- Implications ------------------------
 734 lookupSimpleInst (ImplicInst {}) = return NoInstance
 735
 736 --------------------- Methods ------------------------
 737 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
 738   = do  { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
 739         ; let co_fn = dict_app <.> mkWpTyApps tys
 740         ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
 741   where
 742     span = instLocSpan loc
 743
 744 --------------------- Literals ------------------------
 745 -- Look for short cuts first: if the literal is *definitely* a
 746 -- int, integer, float or a double, generate the real thing here.
 747 -- This is essential (see nofib/spectral/nucleic).
 748 -- [Same shortcut as in newOverloadedLit, but we
 749 --  may have done some unification by now]
 750
 751 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
 752                                                   , ol_rebindable = rebindable }
 753                           , tci_ty = ty, tci_loc = iloc})
 754   | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
 755   | Just witness <- shortCutLit lit_val ty
 756   = do  { let lit' = lit { ol_witness = witness, ol_type = ty }
 757         ; return (GenInst [] (L loc (HsOverLit lit'))) }
 758
 759   | otherwise
 760   = do  { hs_lit <- mkOverLit lit_val
 761         ; from_thing <- tcLookupId (hsOverLitName lit_val)
 762                   -- Not rebindable, so hsOverLitName is the right thing
 763         ; method_inst <- tcInstClassOp iloc from_thing [ty]
 764         ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
 765                               (L loc (HsLit hs_lit))
 766               lit' = lit { ol_witness = witness, ol_type = ty }
 767         ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
 768   where
 769     loc = instLocSpan iloc
 770
 771 --------------------- Dictionaries ------------------------
 772 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
 773   = do  { mb_result <- lookupPred pred
 774         ; case mb_result of {
 775             Nothing -> return NoInstance ;
 776             Just (dfun_id, mb_inst_tys) -> do
 777
 778     { use_stage <- getStage
 779     ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
 780                       (topIdLvl dfun_id) use_stage
 781
 782         -- It's possible that not all the tyvars are in
 783         -- the substitution, tenv. For example:
 784         --      instance C X a => D X where ...
 785         -- (presumably there's a functional dependency in class C)
 786         -- Hence mb_inst_tys :: Either TyVar TcType
 787
 788     ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
 789           inst_tv (Right ty) = return ty
 790     ; tys <- mapM inst_tv mb_inst_tys
 791     ; let
 792         (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
 793         src_loc    = instLocSpan loc
 794         dfun       = HsVar dfun_id
 795     ; if null theta then
 796         return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
 797       else do
 798     { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
 799     ; let co_fn = dict_app <.> mkWpTyApps tys
 800     ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
 801     }}}}
 802
 803 ---------------
 804 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
 805 -- Look up a class constraint in the instance environment
 806 lookupPred pred@(ClassP clas tys)
 807   = do  { eps     <- getEps
 808         ; tcg_env <- getGblEnv
 809         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 810         ; case lookupInstEnv inst_envs clas tys of {
 811             ([(ispec, inst_tys)], [])
 812                 -> do   { let dfun_id = is_dfun ispec
 813                         ; traceTc (text "lookupInst success" <+>
 814                                    vcat [text "dict" <+> ppr pred,
 815                                          text "witness" <+> ppr dfun_id
 816                                          <+> ppr (idType dfun_id) ])
 817                                 -- Record that this dfun is needed
 818                         ; record_dfun_usage dfun_id
 819                         ; return (Just (dfun_id, inst_tys)) } ;
 820
 821             (matches, unifs)
 822                 -> do   { traceTc (text "lookupInst fail" <+>
 823                                    vcat [text "dict" <+> ppr pred,
 824                                          text "matches" <+> ppr matches,
 825                                          text "unifs" <+> ppr unifs])
 826                 -- In the case of overlap (multiple matches) we report
 827                 -- NoInstance here.  That has the effect of making the
 828                 -- context-simplifier return the dict as an irreducible one.
 829                 -- Then it'll be given to addNoInstanceErrs, which will do another
 830                 -- lookupInstEnv to get the detailed info about what went wrong.
 831                         ; return Nothing }
 832         }}
 833
 834 lookupPred (IParam {}) = return Nothing -- Implicit parameters
 835 lookupPred (EqPred {}) = panic "lookupPred EqPred"
 836
 837 record_dfun_usage :: Id -> TcRn ()
 838 record_dfun_usage dfun_id
 839   = do  { hsc_env <- getTopEnv
 840         ; let  dfun_name = idName dfun_id
 841                dfun_mod  = nameModule dfun_name
 842         ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 843              modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 844           then return () -- internal, or in another package
 845            else do { tcg_env <- getGblEnv
 846                    ; updMutVar (tcg_inst_uses tcg_env)
 847                                (`addOneToNameSet` idName dfun_id) }}
 848
 849
 850 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 851 -- Gets both the external-package inst-env
 852 -- and the home-pkg inst env (includes module being compiled)
 853 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 854                      return (eps_inst_env eps, tcg_inst_env env) }
 855 \end{code}
 856
 857
 858
 859 %************************************************************************
 860 %*                                                                      *
 861                 Re-mappable syntax
 862 %*                                                                      *
 863 %************************************************************************
 864
 865 Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
 866 a do-expression.  We have to find (>>) in the current environment, which is
 867 done by the rename. Then we have to check that it has the same type as
 868 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 869 this:
 870
 871   (>>) :: HB m n mn => m a -> n b -> mn b
 872
 873 So the idea is to generate a local binding for (>>), thus:
 874
 875         let then72 :: forall a b. m a -> m b -> m b
 876             then72 = ...something involving the user's (>>)...
 877         in
 878         ...the do-expression...
 879
 880 Now the do-expression can proceed using then72, which has exactly
 881 the expected type.
 882
 883 In fact tcSyntaxName just generates the RHS for then72, because we only
 884 want an actual binding in the do-expression case. For literals, we can
 885 just use the expression inline.
 886
 887 \begin{code}
 888 tcSyntaxName :: InstOrigin
 889              -> TcType                  -- Type to instantiate it at
 890              -> (Name, HsExpr Name)     -- (Standard name, user name)
 891              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 892 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 893 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 894 -- So we do not call it from lookupInst, which is called from tcSimplify
 895
 896 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 897   | std_nm == user_nm
 898   = do id <- newMethodFromName orig ty std_nm
 899        return (std_nm, HsVar id)
 900
 901 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
 902     std_id <- tcLookupId std_nm
 903     let
 904         -- C.f. newMethodAtLoc
 905         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 906         sigma1          = substTyWith [tv] [ty] tau
 907         -- Actually, the "tau-type" might be a sigma-type in the
 908         -- case of locally-polymorphic methods.
 909
 910     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
 911
 912         -- Check that the user-supplied thing has the
 913         -- same type as the standard one.
 914         -- Tiresome jiggling because tcCheckSigma takes a located expression
 915      span <- getSrcSpanM
 916      expr <- tcPolyExpr (L span user_nm_expr) sigma1
 917      return (std_nm, unLoc expr)
 918
 919 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
 920                -> TcRn (TidyEnv, SDoc)
 921 syntaxNameCtxt name orig ty tidy_env = do
 922     inst_loc <- getInstLoc orig
 923     let
 924         msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
 925                                 ptext (sLit "(needed by a syntactic construct)"),
 926                     nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
 927                     nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
 928
 929     return (tidy_env, msg)
 930 \end{code}
 931
 932 %************************************************************************
 933 %*                                                                      *
 934                 EqInsts
 935 %*                                                                      *
 936 %************************************************************************
 937
 938 \begin{code}
 939 mkGivenCo   :: Coercion -> Either TcTyVar Coercion
 940 mkGivenCo   =  Right
 941
 942 mkWantedCo  :: TcTyVar  -> Either TcTyVar Coercion
 943 mkWantedCo  =  Left
 944
 945 fromGivenCo :: Either TcTyVar Coercion -> Coercion
 946 fromGivenCo (Right co)   = co
 947 fromGivenCo _            = panic "fromGivenCo: not a wanted coercion"
 948
 949 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
 950 fromWantedCo _ (Left covar) = covar
 951 fromWantedCo msg _          = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
 952
 953 eitherEqInst :: Inst                -- given or wanted EqInst
 954              -> (TcTyVar  -> a)     --  result if wanted
 955              -> (Coercion -> a)     --  result if given
 956              -> a
 957 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
 958         = case either_co of
 959                 Left  covar -> withWanted covar
 960                 Right co    -> withGiven  co
 961 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
 962
 963 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
 964 mkEqInsts preds cos = zipWithM mkEqInst preds cos
 965
 966 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
 967 mkEqInst (EqPred ty1 ty2) co
 968         = do { uniq <- newUnique
 969              ; src_span <- getSrcSpanM
 970              ; err_ctxt <- getErrCtxt
 971              ; let loc  = InstLoc EqOrigin src_span err_ctxt
 972                    name = mkName uniq src_span
 973                    inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
 974              ; return inst
 975              }
 976         where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
 977 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
 978
 979 mkWantedEqInst :: PredType -> TcM Inst
 980 mkWantedEqInst pred@(EqPred ty1 ty2)
 981   = do { cotv <- newMetaCoVar ty1 ty2
 982        ; mkEqInst pred (Left cotv)
 983        }
 984 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
 985
 986 -- type inference:
 987 --      We want to promote the wanted EqInst to a given EqInst
 988 --      in the signature context.
 989 --      This means we have to give the coercion a name
 990 --      and fill it in as its own name.
 991 finalizeEqInst
 992         :: Inst                 -- wanted
 993         -> TcM Inst             -- given
 994 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
 995         = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
 996              ; writeWantedCoercion wanted (TyVarTy var)
 997              ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
 998              ; return given
 999              }
1000 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1001
1002 writeWantedCoercion
1003         :: Inst         -- wanted EqInst
1004         -> Coercion     -- coercion to fill the hole with
1005         -> TcM ()
1006 writeWantedCoercion wanted co
1007         = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1008              ; writeMetaTyVar cotv co
1009              }
1010
1011 eqInstType :: Inst -> TcType
1012 eqInstType inst = eitherEqInst inst mkTyVarTy id
1013
1014 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1015 eqInstCoercion = tci_co
1016
1017 eqInstTys :: Inst -> (TcType, TcType)
1018 eqInstTys inst = (tci_left inst, tci_right inst)
1019
1020 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1021 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
1022 \end{code}