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