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