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