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