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