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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module Inst (
  17         Inst,
  18
  19         pprInstances, pprDictsTheta, pprDictsInFull,    -- User error messages
  20         showLIE, pprInst, pprInsts, pprInstInFull,      -- Debugging messages
  21
  22         tidyInsts, tidyMoreInsts,
  23
  24         newDictBndr, newDictBndrs, newDictBndrsO,
  25         instCall, instStupidTheta,
  26         cloneDict, mkOverLit,
  27         newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
  28         tcInstClassOp,
  29         tcSyntaxName, isHsVar,
  30
  31         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  32         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  33         getDictClassTys, dictPred,
  34
  35         lookupSimpleInst, LookupInstResult(..),
  36         tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
  37
  38         isAbstractableInst, isEqInst,
  39         isDict, isClassDict, isMethod, isImplicInst,
  40         isIPDict, isInheritableInst, isMethodOrLit,
  41         isTyVarDict, isMethodFor,
  42
  43         zonkInst, zonkInsts,
  44         instToId, instToVar, instType, instName, instToDictBind,
  45         addInstToDictBind,
  46
  47         InstOrigin(..), InstLoc, pprInstLoc,
  48
  49         mkWantedCo, mkGivenCo,
  50         fromWantedCo, fromGivenCo,
  51         eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
  52         finalizeEqInst, writeWantedCoercion,
  53         eqInstType, updateEqInstCoercion,
  54         eqInstCoercion, eqInstTys
  55     ) where
  56
  57 #include "HsVersions.h"
  58
  59 import {-# SOURCE #-}   TcExpr( tcPolyExpr )
  60 import {-# SOURCE #-}   TcUnify( boxyUnify, unifyType )
  61
  62 import FastString
  63 import HsSyn
  64 import TcHsSyn
  65 import TcRnMonad
  66 import TcEnv
  67 import InstEnv
  68 import FunDeps
  69 import TcMType
  70 import TcType
  71 import Type
  72 import TypeRep
  73 import Class
  74 import Unify
  75 import Module
  76 import Coercion
  77 import HscTypes
  78 import CoreFVs
  79 import DataCon
  80 import Id
  81 import Name
  82 import NameSet
  83 import Literal
  84 import Var      ( Var, TyVar )
  85 import qualified Var
  86 import VarEnv
  87 import VarSet
  88 import TysWiredIn
  89 import PrelNames
  90 import BasicTypes
  91 import SrcLoc
  92 import DynFlags
  93 import Bag
  94 import Maybes
  95 import Util
  96 import Unique
  97 import Outputable
  98 import Data.List
  99 import TypeRep
 100 import Class
 101
 102 import Control.Monad
 103 \end{code}
 104
 105
 106 Selection
 107 ~~~~~~~~~
 108 \begin{code}
 109 instName :: Inst -> Name
 110 instName (EqInst {tci_name = name}) = name
 111 instName inst = Var.varName (instToVar inst)
 112
 113 instToId :: Inst -> TcId
 114 instToId inst = WARN( not (isId id), ppr inst )
 115               id
 116               where
 117                 id = instToVar inst
 118
 119 instToVar :: Inst -> Var
 120 instToVar (LitInst {tci_name = nm, tci_ty = ty})
 121   = mkLocalId nm ty
 122 instToVar (Method {tci_id = id})
 123   = id
 124 instToVar (Dict {tci_name = nm, tci_pred = pred})
 125   | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
 126   | otherwise     = mkLocalId nm (mkPredTy pred)
 127 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
 128                        tci_wanted = wanteds})
 129   = mkLocalId nm (mkImplicTy tvs givens wanteds)
 130 instToVar i@(EqInst {})
 131   = eitherEqInst i id (\(TyVarTy covar) -> covar)
 132
 133 instType :: Inst -> Type
 134 instType (LitInst {tci_ty = ty})  = ty
 135 instType (Method {tci_id = id})   = idType id
 136 instType (Dict {tci_pred = pred}) = mkPredTy pred
 137 instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 138                                                (tci_wanted imp)
 139 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
 140 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
 141
 142 mkImplicTy tvs givens wanteds   -- The type of an implication constraint
 143   = ASSERT( all isAbstractableInst givens )
 144     -- pprTrace "mkImplicTy" (ppr givens) $
 145     -- See [Equational Constraints in Implication Constraints]
 146     let dict_wanteds = filter (not . isEqInst) wanteds
 147     in
 148       mkForAllTys tvs $
 149       mkPhiTy (map dictPred givens) $
 150       if isSingleton dict_wanteds then
 151         instType (head dict_wanteds)
 152       else
 153         mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
 154
 155 dictPred (Dict {tci_pred = pred}) = pred
 156 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
 157 dictPred inst                     = pprPanic "dictPred" (ppr inst)
 158
 159 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
 160 getDictClassTys inst                     = pprPanic "getDictClassTys" (ppr inst)
 161
 162 -- fdPredsOfInst is used to get predicates that contain functional
 163 -- dependencies *or* might do so.  The "might do" part is because
 164 -- a constraint (C a b) might have a superclass with FDs
 165 -- Leaving these in is really important for the call to fdPredsOfInsts
 166 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 167 -- which is supposed to be conservative
 168 fdPredsOfInst (Dict {tci_pred = pred})       = [pred]
 169 fdPredsOfInst (Method {tci_theta = theta})   = theta
 170 fdPredsOfInst (ImplicInst {tci_given = gs,
 171                            tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
 172 fdPredsOfInst (LitInst {})                   = []
 173 fdPredsOfInst (EqInst {})                    = []
 174
 175 fdPredsOfInsts :: [Inst] -> [PredType]
 176 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 177
 178 isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
 179 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
 180 isInheritableInst other                        = True
 181
 182
 183 ---------------------------------
 184 -- Get the implicit parameters mentioned by these Insts
 185 -- NB: the results of these functions are insensitive to zonking
 186
 187 ipNamesOfInsts :: [Inst] -> [Name]
 188 ipNamesOfInst  :: Inst   -> [Name]
 189 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 190
 191 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
 192 ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
 193 ipNamesOfInst other                          = []
 194
 195 ---------------------------------
 196 tyVarsOfInst :: Inst -> TcTyVarSet
 197 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 198 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
 199 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
 200                                  -- The id might have free type variables; in the case of
 201                                  -- locally-overloaded class methods, for example
 202 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
 203   = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
 204     `minusVarSet` mkVarSet tvs
 205     `unionVarSet` unionVarSets (map varTypeTyVars tvs)
 206                 -- Remember the free tyvars of a coercion
 207 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
 208
 209 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 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 other       = False
 232
 233 isDict :: Inst -> Bool
 234 isDict (Dict {}) = True
 235 isDict other     = False
 236
 237 isClassDict :: Inst -> Bool
 238 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
 239 isClassDict other                    = False
 240
 241 isTyVarDict :: Inst -> Bool
 242 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
 243 isTyVarDict other                    = False
 244
 245 isIPDict :: Inst -> Bool
 246 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
 247 isIPDict other                    = False
 248
 249 isImplicInst (ImplicInst {}) = True
 250 isImplicInst other           = False
 251
 252 isMethod :: Inst -> Bool
 253 isMethod (Method {}) = True
 254 isMethod other       = False
 255
 256 isMethodFor :: TcIdSet -> Inst -> Bool
 257 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
 258 isMethodFor ids inst                    = False
 259
 260 isMethodOrLit :: Inst -> Bool
 261 isMethodOrLit (Method {})  = True
 262 isMethodOrLit (LitInst {}) = True
 263 isMethodOrLit other        = False
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection{Building dictionaries}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 -- newDictBndrs makes a dictionary at a binding site
 274 -- instCall makes a dictionary at an occurrence site
 275 --      and throws it into the LIE
 276
 277 \begin{code}
 278 ----------------
 279 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 280 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 281                               ; newDictBndrs loc theta }
 282
 283 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 284 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 285
 286 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 287 newDictBndr inst_loc pred@(EqPred ty1 ty2)
 288   = do { uniq <- newUnique
 289         ; let name = mkPredName uniq inst_loc pred
 290         ; return (EqInst {tci_name  = name,
 291                           tci_loc   = inst_loc,
 292                           tci_left  = ty1,
 293                           tci_right = ty2,
 294                           tci_co    = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
 295        }
 296 newDictBndr inst_loc pred
 297   = do  { uniq <- newUnique
 298         ; let name = mkPredName uniq inst_loc pred
 299         ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
 300
 301 ----------------
 302 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 303 -- Instantiate the constraints of a call
 304 --      (instCall o tys theta)
 305 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 306 -- (b) Throws these dictionaries into the LIE
 307 -- (c) Returns an HsWrapper ([.] tys dicts)
 308
 309 instCall orig tys theta
 310   = do  { loc <- getInstLoc orig
 311         ; dict_app <- instCallDicts loc theta
 312         ; return (dict_app <.> mkWpTyApps tys) }
 313
 314 ----------------
 315 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 316 -- Similar to instCall, but only emit the constraints in the LIE
 317 -- Used exclusively for the 'stupid theta' of a data constructor
 318 instStupidTheta orig theta
 319   = do  { loc <- getInstLoc orig
 320         ; _co <- instCallDicts loc theta        -- Discard the coercion
 321         ; return () }
 322
 323 ----------------
 324 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
 325 -- Instantiates the TcTheta, puts all constraints thereby generated
 326 -- into the LIE, and returns a HsWrapper to enclose the call site.
 327 -- This is the key place where equality predicates
 328 -- are unleashed into the world
 329 instCallDicts loc [] = return idHsWrapper
 330
 331 -- instCallDicts loc (EqPred ty1 ty2 : preds)
 332 --   = do  { unifyType ty1 ty2  -- For now, we insist that they unify right away
 333 --                              -- Later on, when we do associated types,
 334 --                              -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
 335 --      ; (dicts, co_fn) <- instCallDicts loc preds
 336 --      ; return (dicts, co_fn <.> WpTyApp ty1) }
 337 --      -- We use type application to apply the function to the
 338 --      -- coercion; here ty1 *is* the appropriate identity coercion
 339
 340 instCallDicts loc (EqPred ty1 ty2 : preds)
 341   = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
 342         ; coi <- boxyUnify ty1 ty2
 343 --      ; coi <- unifyType ty1 ty2
 344         ; let co = fromCoI coi ty1
 345         ; co_fn <- instCallDicts loc preds
 346         ; return (co_fn <.> WpTyApp co) }
 347
 348 instCallDicts loc (pred : preds)
 349   = do  { uniq <- newUnique
 350         ; let name = mkPredName uniq loc pred
 351               dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
 352         ; extendLIE dict
 353         ; co_fn <- instCallDicts loc preds
 354         ; return (co_fn <.> WpApp (instToId dict)) }
 355
 356 -------------
 357 cloneDict :: Inst -> TcM Inst
 358 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
 359                                      ; return (dict {tci_name = setNameUnique nm uniq}) }
 360 cloneDict eq@(EqInst {})        = return eq
 361 cloneDict other = pprPanic "cloneDict" (ppr other)
 362
 363 -- For vanilla implicit parameters, there is only one in scope
 364 -- at any time, so we used to use the name of the implicit parameter itself
 365 -- But with splittable implicit parameters there may be many in
 366 -- scope, so we make up a new namea.
 367 newIPDict :: InstOrigin -> IPName Name -> Type
 368           -> TcM (IPName Id, Inst)
 369 newIPDict orig ip_name ty = do
 370     inst_loc <- getInstLoc orig
 371     uniq <- newUnique
 372     let
 373         pred = IParam ip_name ty
 374         name = mkPredName uniq inst_loc pred
 375         dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
 376
 377     return (mapIPName (\n -> instToId dict) ip_name, dict)
 378 \end{code}
 379
 380
 381 \begin{code}
 382 mkPredName :: Unique -> InstLoc -> PredType -> Name
 383 mkPredName uniq loc pred_ty
 384   = mkInternalName uniq occ (instLocSpan loc)
 385   where
 386     occ = case pred_ty of
 387             ClassP cls _ -> mkDictOcc (getOccName cls)
 388             IParam ip  _ -> getOccName (ipNameName ip)
 389             EqPred ty  _ -> mkEqPredCoOcc baseOcc
 390               where
 391                 -- we use the outermost tycon of the lhs, if there is one, to
 392                 -- improve readability of Core code
 393                 baseOcc = case splitTyConApp_maybe ty of
 394                             Nothing      -> mkOccName tcName "$"
 395                             Just (tc, _) -> getOccName tc
 396 \end{code}
 397
 398 %************************************************************************
 399 %*                                                                      *
 400 \subsection{Building methods (calls of overloaded functions)}
 401 %*                                                                      *
 402 %************************************************************************
 403
 404
 405 \begin{code}
 406 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 407 newMethodFromName origin ty name = do
 408     id <- tcLookupId name
 409         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 410         -- always a class op, but with -fno-implicit-prelude GHC is
 411         -- meant to find whatever thing is in scope, and that may
 412         -- be an ordinary function.
 413     loc <- getInstLoc origin
 414     inst <- tcInstClassOp loc id [ty]
 415     extendLIE inst
 416     return (instToId inst)
 417
 418 newMethodWithGivenTy orig id tys = do
 419     loc <- getInstLoc orig
 420     inst <- newMethod loc id tys
 421     extendLIE inst
 422     return (instToId inst)
 423
 424 --------------------------------------------
 425 -- tcInstClassOp, and newMethod do *not* drop the
 426 -- Inst into the LIE; they just returns the Inst
 427 -- This is important because they are used by TcSimplify
 428 -- to simplify Insts
 429
 430 -- NB: the kind of the type variable to be instantiated
 431 --     might be a sub-kind of the type to which it is applied,
 432 --     notably when the latter is a type variable of kind ??
 433 --     Hence the call to checkKind
 434 -- A worry: is this needed anywhere else?
 435 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 436 tcInstClassOp inst_loc sel_id tys = do
 437     let
 438         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 439     zipWithM_ checkKind tyvars tys
 440     newMethod inst_loc sel_id tys
 441
 442 checkKind :: TyVar -> TcType -> TcM ()
 443 -- Ensure that the type has a sub-kind of the tyvar
 444 checkKind tv ty
 445   = do  { let ty1 = ty
 446                 -- ty1 <- zonkTcType ty
 447         ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
 448           then return ()
 449           else
 450
 451     pprPanic "checkKind: adding kind constraint"
 452              (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
 453                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 454         }
 455 --    do        { tv1 <- tcInstTyVar tv
 456 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 457
 458
 459 ---------------------------
 460 newMethod inst_loc id tys = do
 461     new_uniq <- newUnique
 462     let
 463         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 464         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 465         inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
 466                               tci_theta = theta, tci_loc = inst_loc}
 467         loc         = instLocSpan inst_loc
 468
 469     return inst
 470 \end{code}
 471
 472 \begin{code}
 473 mkOverLit :: OverLitVal -> TcM HsLit
 474 mkOverLit (HsIntegral i)
 475   = do  { integer_ty <- tcMetaTy integerTyConName
 476         ; return (HsInteger i integer_ty) }
 477
 478 mkOverLit (HsFractional r)
 479   = do  { rat_ty <- tcMetaTy rationalTyConName
 480         ; return (HsRat r rat_ty) }
 481
 482 mkOverLit (HsIsString s) = return (HsString s)
 483
 484 isHsVar :: HsExpr Name -> Name -> Bool
 485 isHsVar (HsVar f) g = f==g
 486 isHsVar other     g = False
 487 \end{code}
 488
 489
 490 %************************************************************************
 491 %*                                                                      *
 492 \subsection{Zonking}
 493 %*                                                                      *
 494 %************************************************************************
 495
 496 Zonking makes sure that the instance types are fully zonked.
 497
 498 \begin{code}
 499 zonkInst :: Inst -> TcM Inst
 500 zonkInst dict@(Dict { tci_pred = pred}) = do
 501     new_pred <- zonkTcPredType pred
 502     return (dict {tci_pred = new_pred})
 503
 504 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
 505     new_id <- zonkId id
 506         -- Essential to zonk the id in case it's a local variable
 507         -- Can't use zonkIdOcc because the id might itself be
 508         -- an InstId, in which case it won't be in scope
 509
 510     new_tys <- zonkTcTypes tys
 511     new_theta <- zonkTcThetaType theta
 512     return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
 513         -- No need to zonk the tci_id
 514
 515 zonkInst lit@(LitInst {tci_ty = ty}) = do
 516     new_ty <- zonkTcType ty
 517     return (lit {tci_ty = new_ty})
 518
 519 zonkInst implic@(ImplicInst {})
 520   = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
 521     do  { givens'  <- zonkInsts (tci_given  implic)
 522         ; wanteds' <- zonkInsts (tci_wanted implic)
 523         ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
 524
 525 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
 526   = do { co' <- eitherEqInst eqinst
 527                   (\covar -> return (mkWantedCo covar))
 528                   (\co    -> liftM mkGivenCo $ zonkTcType co)
 529        ; ty1' <- zonkTcType ty1
 530        ; ty2' <- zonkTcType ty2
 531        ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
 532        }
 533
 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, tci_co = co})
 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 ispecs
 691   = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
 692   where
 693     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 694         -- Print the dfun name itself too
 695
 696 funDepErr ispec ispecs
 697   = addDictLoc ispec $
 698     addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
 699                2 (pprInstances (ispec:ispecs)))
 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 ispec thing_inside
 706   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 707   where
 708    loc = getSrcLoc ispec
 709 \end{code}
 710
 711
 712 %************************************************************************
 713 %*                                                                      *
 714 \subsection{Looking up Insts}
 715 %*                                                                      *
 716 %************************************************************************
 717
 718 \begin{code}
 719 data LookupInstResult
 720   = NoInstance
 721   | GenInst [Inst] (LHsExpr TcId)       -- The expression and its needed insts
 722
 723 lookupSimpleInst :: Inst -> TcM LookupInstResult
 724 -- This is "simple" in that it returns NoInstance for implication constraints
 725
 726 -- It's important that lookupInst does not put any new stuff into
 727 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 728 -- the LookupInstResult, where they can be further processed by tcSimplify
 729
 730 lookupSimpleInst (EqInst {}) = return NoInstance
 731
 732 --------------------- Implications ------------------------
 733 lookupSimpleInst (ImplicInst {}) = return NoInstance
 734
 735 --------------------- Methods ------------------------
 736 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
 737   = do  { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
 738         ; let co_fn = dict_app <.> mkWpTyApps tys
 739         ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
 740   where
 741     span = instLocSpan loc
 742
 743 --------------------- Literals ------------------------
 744 -- Look for short cuts first: if the literal is *definitely* a
 745 -- int, integer, float or a double, generate the real thing here.
 746 -- This is essential (see nofib/spectral/nucleic).
 747 -- [Same shortcut as in newOverloadedLit, but we
 748 --  may have done some unification by now]
 749
 750 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
 751                                                   , ol_rebindable = rebindable }
 752                           , tci_ty = ty, tci_loc = iloc})
 753 #ifdef DEBUG
 754   | rebindable = panic "lookupSimpleInst"               -- A LitInst invariant
 755 #endif
 756   | Just witness <- shortCutLit lit_val ty
 757   = do  { let lit' = lit { ol_witness = witness, ol_type = ty }
 758         ; return (GenInst [] (L loc (HsOverLit lit'))) }
 759
 760   | otherwise
 761   = do  { hs_lit <- mkOverLit lit_val
 762         ; from_thing <- tcLookupId (hsOverLitName lit_val)
 763                   -- Not rebindable, so hsOverLitName is the right thing
 764         ; method_inst <- tcInstClassOp iloc from_thing [ty]
 765         ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
 766                               (L loc (HsLit hs_lit))
 767               lit' = lit { ol_witness = witness, ol_type = ty }
 768         ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
 769   where
 770     loc = instLocSpan iloc
 771
 772 --------------------- Dictionaries ------------------------
 773 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
 774   = do  { mb_result <- lookupPred pred
 775         ; case mb_result of {
 776             Nothing -> return NoInstance ;
 777             Just (dfun_id, mb_inst_tys) -> do
 778
 779     { use_stage <- getStage
 780     ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
 781                       (topIdLvl dfun_id) use_stage
 782
 783         -- It's possible that not all the tyvars are in
 784         -- the substitution, tenv. For example:
 785         --      instance C X a => D X where ...
 786         -- (presumably there's a functional dependency in class C)
 787         -- Hence mb_inst_tys :: Either TyVar TcType
 788
 789     ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
 790           inst_tv (Right ty) = return ty
 791     ; tys <- mapM inst_tv mb_inst_tys
 792     ; let
 793         (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
 794         src_loc    = instLocSpan loc
 795         dfun       = HsVar dfun_id
 796     ; if null theta then
 797         return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
 798       else do
 799     { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
 800     ; let co_fn = dict_app <.> mkWpTyApps tys
 801     ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
 802     }}}}
 803
 804 ---------------
 805 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
 806 -- Look up a class constraint in the instance environment
 807 lookupPred pred@(ClassP clas tys)
 808   = do  { eps     <- getEps
 809         ; tcg_env <- getGblEnv
 810         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 811         ; case lookupInstEnv inst_envs clas tys of {
 812             ([(ispec, inst_tys)], [])
 813                 -> do   { let dfun_id = is_dfun ispec
 814                         ; traceTc (text "lookupInst success" <+>
 815                                    vcat [text "dict" <+> ppr pred,
 816                                          text "witness" <+> ppr dfun_id
 817                                          <+> ppr (idType dfun_id) ])
 818                                 -- Record that this dfun is needed
 819                         ; record_dfun_usage dfun_id
 820                         ; return (Just (dfun_id, inst_tys)) } ;
 821
 822             (matches, unifs)
 823                 -> do   { traceTc (text "lookupInst fail" <+>
 824                                    vcat [text "dict" <+> ppr pred,
 825                                          text "matches" <+> ppr matches,
 826                                          text "unifs" <+> ppr unifs])
 827                 -- In the case of overlap (multiple matches) we report
 828                 -- NoInstance here.  That has the effect of making the
 829                 -- context-simplifier return the dict as an irreducible one.
 830                 -- Then it'll be given to addNoInstanceErrs, which will do another
 831                 -- lookupInstEnv to get the detailed info about what went wrong.
 832                         ; return Nothing }
 833         }}
 834
 835 lookupPred (IParam {}) = return Nothing -- Implicit parameters
 836 lookupPred (EqPred {}) = panic "lookupPred EqPred"
 837
 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 -fno-implicit-prelude 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 name orig ty tidy_env = do
 920     inst_loc <- getInstLoc orig
 921     let
 922         msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
 923                                 ptext (sLit "(needed by a syntactic construct)"),
 924                     nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
 925                     nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
 926
 927     return (tidy_env, msg)
 928 \end{code}
 929
 930 %************************************************************************
 931 %*                                                                      *
 932                 EqInsts
 933 %*                                                                      *
 934 %************************************************************************
 935
 936 \begin{code}
 937 mkGivenCo   :: Coercion -> Either TcTyVar Coercion
 938 mkGivenCo   =  Right
 939
 940 mkWantedCo  :: TcTyVar  -> Either TcTyVar Coercion
 941 mkWantedCo  =  Left
 942
 943 fromGivenCo :: Either TcTyVar Coercion -> Coercion
 944 fromGivenCo (Right co)   = co
 945 fromGivenCo _            = panic "fromGivenCo: not a wanted coercion"
 946
 947 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
 948 fromWantedCo _ (Left covar) = covar
 949 fromWantedCo msg _          = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
 950
 951 eitherEqInst :: Inst                -- given or wanted EqInst
 952              -> (TcTyVar  -> a)     --  result if wanted
 953              -> (Coercion -> a)     --  result if given
 954              -> a
 955 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
 956         = case either_co of
 957                 Left  covar -> withWanted covar
 958                 Right co    -> withGiven  co
 959
 960 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
 961 mkEqInsts preds cos = zipWithM mkEqInst preds cos
 962
 963 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
 964 mkEqInst (EqPred ty1 ty2) co
 965         = do { uniq <- newUnique
 966              ; src_span <- getSrcSpanM
 967              ; err_ctxt <- getErrCtxt
 968              ; let loc  = InstLoc EqOrigin src_span err_ctxt
 969                    name = mkName uniq src_span
 970                    inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
 971              ; return inst
 972              }
 973         where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
 974
 975 mkWantedEqInst :: PredType -> TcM Inst
 976 mkWantedEqInst pred@(EqPred ty1 ty2)
 977   = do { cotv <- newMetaCoVar ty1 ty2
 978        ; mkEqInst pred (Left cotv)
 979        }
 980
 981 -- type inference:
 982 --      We want to promote the wanted EqInst to a given EqInst
 983 --      in the signature context.
 984 --      This means we have to give the coercion a name
 985 --      and fill it in as its own name.
 986 finalizeEqInst
 987         :: Inst                 -- wanted
 988         -> TcM Inst             -- given
 989 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
 990         = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
 991              ; writeWantedCoercion wanted (TyVarTy var)
 992              ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
 993              ; return given
 994              }
 995
 996 writeWantedCoercion
 997         :: Inst         -- wanted EqInst
 998         -> Coercion     -- coercion to fill the hole with
 999         -> TcM ()
1000 writeWantedCoercion wanted co
1001         = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1002              ; writeMetaTyVar cotv co
1003              }
1004
1005 eqInstType :: Inst -> TcType
1006 eqInstType inst = eitherEqInst inst mkTyVarTy id
1007
1008 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1009 eqInstCoercion = tci_co
1010
1011 eqInstTys :: Inst -> (TcType, TcType)
1012 eqInstTys inst = (tci_left inst, tci_right inst)
1013
1014 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1015 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
1016 \end{code}