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