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