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