compiler/typecheck/Inst.lhs

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