compiler/typecheck/Inst.lhs

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