compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The @Inst@ type: dictionaries or method instances
   7
   8 \begin{code}
   9 module Inst (
  10         Inst,
  11
  12         pprInstances, pprDictsTheta, pprDictsInFull,    -- User error messages
  13         showLIE, pprInst, pprInsts, pprInstInFull,      -- Debugging messages
  14
  15         tidyInsts, tidyMoreInsts,
  16
  17         newDictBndr, newDictBndrs, newDictBndrsO,
  18         instCall, instStupidTheta,
  19         cloneDict,
  20         shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
  21         newMethod, newMethodFromName, newMethodWithGivenTy,
  22         tcInstClassOp,
  23         tcSyntaxName, isHsVar,
  24
  25         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  26         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  27         getDictClassTys, dictPred,
  28
  29         lookupSimpleInst, LookupInstResult(..),
  30         tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
  31
  32         isDict, isClassDict, isMethod, isImplicInst,
  33         isIPDict, isInheritableInst, isMethodOrLit,
  34         isTyVarDict, isMethodFor,
  35
  36         zonkInst, zonkInsts,
  37         instToId, instToVar, instName,
  38
  39         InstOrigin(..), InstLoc, pprInstLoc
  40     ) where
  41
  42 #include "HsVersions.h"
  43
  44 import {-# SOURCE #-}   TcExpr( tcPolyExpr )
  45 import {-# SOURCE #-}   TcUnify( unifyType )
  46
  47 import FastString(FastString)
  48 import HsSyn
  49 import TcHsSyn
  50 import TcRnMonad
  51 import TcEnv
  52 import InstEnv
  53 import FunDeps
  54 import TcMType
  55 import TcType
  56 import Type
  57 import 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` varTypeTyVars 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)
 169     `minusVarSet` mkVarSet tvs
 170     `unionVarSet` unionVarSets (map varTypeTyVars tvs)
 171                 -- Remember the free tyvars of a coercion
 172
 173 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 174 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 175 \end{code}
 176
 177 Predicates
 178 ~~~~~~~~~~
 179 \begin{code}
 180 isDict :: Inst -> Bool
 181 isDict (Dict {}) = True
 182 isDict other     = False
 183
 184 isClassDict :: Inst -> Bool
 185 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
 186 isClassDict other                    = False
 187
 188 isTyVarDict :: Inst -> Bool
 189 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
 190 isTyVarDict other                    = False
 191
 192 isIPDict :: Inst -> Bool
 193 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
 194 isIPDict other                    = False
 195
 196 isImplicInst (ImplicInst {}) = True
 197 isImplicInst other           = False
 198
 199 isMethod :: Inst -> Bool
 200 isMethod (Method {}) = True
 201 isMethod other       = False
 202
 203 isMethodFor :: TcIdSet -> Inst -> Bool
 204 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
 205 isMethodFor ids inst                    = False
 206
 207 isMethodOrLit :: Inst -> Bool
 208 isMethodOrLit (Method {})  = True
 209 isMethodOrLit (LitInst {}) = True
 210 isMethodOrLit other        = False
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Building dictionaries}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 -- newDictBndrs makes a dictionary at a binding site
 221 -- instCall makes a dictionary at an occurrence site
 222 --      and throws it into the LIE
 223
 224 \begin{code}
 225 ----------------
 226 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 227 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 228                               ; newDictBndrs loc theta }
 229
 230 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 231 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 232
 233 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 234 newDictBndr inst_loc pred
 235   = do  { uniq <- newUnique
 236         ; let name = mkPredName uniq inst_loc pred
 237         ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
 238
 239 ----------------
 240 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 241 -- Instantiate the constraints of a call
 242 --      (instCall o tys theta)
 243 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 244 -- (b) Throws these dictionaries into the LIE
 245 -- (c) Eeturns an HsWrapper ([.] tys dicts)
 246
 247 instCall orig tys theta
 248   = do  { loc <- getInstLoc orig
 249         ; (dicts, dict_app) <- instCallDicts loc theta
 250         ; extendLIEs dicts
 251         ; return (dict_app <.> mkWpTyApps tys) }
 252
 253 ----------------
 254 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 255 -- Similar to instCall, but only emit the constraints in the LIE
 256 -- Used exclusively for the 'stupid theta' of a data constructor
 257 instStupidTheta orig theta
 258   = do  { loc <- getInstLoc orig
 259         ; (dicts, _) <- instCallDicts loc theta
 260         ; extendLIEs dicts }
 261
 262 ----------------
 263 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
 264 -- This is the key place where equality predicates
 265 -- are unleashed into the world
 266 instCallDicts loc [] = return ([], idHsWrapper)
 267
 268 instCallDicts loc (EqPred ty1 ty2 : preds)
 269   = do  { unifyType ty1 ty2     -- For now, we insist that they unify right away
 270                                 -- Later on, when we do associated types,
 271                                 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
 272         ; (dicts, co_fn) <- instCallDicts loc preds
 273         ; return (dicts, co_fn <.> WpTyApp ty1) }
 274         -- We use type application to apply the function to the
 275         -- coercion; here ty1 *is* the appropriate identity coercion
 276
 277 instCallDicts loc (pred : preds)
 278   = do  { uniq <- newUnique
 279         ; let name = mkPredName uniq loc pred
 280               dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
 281         ; (dicts, co_fn) <- instCallDicts loc preds
 282         ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
 283
 284 -------------
 285 cloneDict :: Inst -> TcM Inst
 286 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
 287                                      ; return (dict {tci_name = setNameUnique nm uniq}) }
 288 cloneDict other = pprPanic "cloneDict" (ppr other)
 289
 290 -- For vanilla implicit parameters, there is only one in scope
 291 -- at any time, so we used to use the name of the implicit parameter itself
 292 -- But with splittable implicit parameters there may be many in
 293 -- scope, so we make up a new namea.
 294 newIPDict :: InstOrigin -> IPName Name -> Type
 295           -> TcM (IPName Id, Inst)
 296 newIPDict orig ip_name ty
 297   = getInstLoc orig                     `thenM` \ inst_loc ->
 298     newUnique                           `thenM` \ uniq ->
 299     let
 300         pred = IParam ip_name ty
 301         name = mkPredName uniq inst_loc pred
 302         dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
 303     in
 304     returnM (mapIPName (\n -> instToId dict) ip_name, dict)
 305 \end{code}
 306
 307
 308 \begin{code}
 309 mkPredName :: Unique -> InstLoc -> PredType -> Name
 310 mkPredName uniq loc pred_ty
 311   = mkInternalName uniq occ (instLocSpan loc)
 312   where
 313     occ = case pred_ty of
 314             ClassP cls _ -> mkDictOcc (getOccName cls)
 315             IParam ip  _ -> getOccName (ipNameName ip)
 316             EqPred ty  _ -> mkEqPredCoOcc baseOcc
 317               where
 318                 -- we use the outermost tycon of the lhs, if there is one, to
 319                 -- improve readability of Core code
 320                 baseOcc = case splitTyConApp_maybe ty of
 321                             Nothing      -> mkOccName tcName "$"
 322                             Just (tc, _) -> getOccName tc
 323 \end{code}
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsection{Building methods (calls of overloaded functions)}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331
 332 \begin{code}
 333 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 334 newMethodFromName origin ty name
 335   = tcLookupId name             `thenM` \ id ->
 336         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 337         -- always a class op, but with -fno-implicit-prelude GHC is
 338         -- meant to find whatever thing is in scope, and that may
 339         -- be an ordinary function.
 340     getInstLoc origin           `thenM` \ loc ->
 341     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 342     extendLIE inst              `thenM_`
 343     returnM (instToId inst)
 344
 345 newMethodWithGivenTy orig id tys
 346   = getInstLoc orig             `thenM` \ loc ->
 347     newMethod loc id tys        `thenM` \ inst ->
 348     extendLIE inst              `thenM_`
 349     returnM (instToId inst)
 350
 351 --------------------------------------------
 352 -- tcInstClassOp, and newMethod do *not* drop the
 353 -- Inst into the LIE; they just returns the Inst
 354 -- This is important because they are used by TcSimplify
 355 -- to simplify Insts
 356
 357 -- NB: the kind of the type variable to be instantiated
 358 --     might be a sub-kind of the type to which it is applied,
 359 --     notably when the latter is a type variable of kind ??
 360 --     Hence the call to checkKind
 361 -- A worry: is this needed anywhere else?
 362 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 363 tcInstClassOp inst_loc sel_id tys
 364   = let
 365         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 366     in
 367     zipWithM_ checkKind tyvars tys      `thenM_`
 368     newMethod inst_loc sel_id tys
 369
 370 checkKind :: TyVar -> TcType -> TcM ()
 371 -- Ensure that the type has a sub-kind of the tyvar
 372 checkKind tv ty
 373   = do  { let ty1 = ty
 374                 -- ty1 <- zonkTcType ty
 375         ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
 376           then return ()
 377           else
 378
 379     pprPanic "checkKind: adding kind constraint"
 380              (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
 381                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 382         }
 383 --    do        { tv1 <- tcInstTyVar tv
 384 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 385
 386
 387 ---------------------------
 388 newMethod inst_loc id tys
 389   = newUnique           `thenM` \ new_uniq ->
 390     let
 391         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 392         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 393         inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
 394                               tci_theta = theta, tci_loc = inst_loc}
 395         loc         = instLocSpan inst_loc
 396     in
 397     returnM inst
 398 \end{code}
 399
 400 \begin{code}
 401 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
 402 shortCutIntLit i ty
 403   | isIntTy ty && inIntRange i          -- Short cut for Int
 404   = Just (HsLit (HsInt i))
 405   | isIntegerTy ty                      -- Short cut for Integer
 406   = Just (HsLit (HsInteger i ty))
 407   | otherwise = Nothing
 408
 409 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
 410 shortCutFracLit f ty
 411   | isFloatTy ty
 412   = Just (mk_lit floatDataCon (HsFloatPrim f))
 413   | isDoubleTy ty
 414   = Just (mk_lit doubleDataCon (HsDoublePrim f))
 415   | otherwise = Nothing
 416   where
 417     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 418
 419 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
 420 shortCutStringLit s ty
 421   | isStringTy ty                       -- Short cut for String
 422   = Just (HsLit (HsString s))
 423   | otherwise = Nothing
 424
 425 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 426 mkIntegerLit i
 427   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 428     getSrcSpanM                 `thenM` \ span ->
 429     returnM (L span $ HsLit (HsInteger i integer_ty))
 430
 431 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 432 mkRatLit r
 433   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 434     getSrcSpanM                 `thenM` \ span ->
 435     returnM (L span $ HsLit (HsRat r rat_ty))
 436
 437 mkStrLit :: FastString -> TcM (LHsExpr TcId)
 438 mkStrLit s
 439   = --tcMetaTy stringTyConName  `thenM` \ string_ty ->
 440     getSrcSpanM                 `thenM` \ span ->
 441     returnM (L span $ HsLit (HsString s))
 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 --------------------- Implications ------------------------
 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 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
 711   | Just expr <- shortCutStringLit s ty
 712   = returnM (GenInst [] (noLoc expr))
 713   | otherwise
 714   = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
 715     tcLookupId fromStringName                   `thenM` \ from_string ->
 716     tcInstClassOp loc from_string [ty]          `thenM` \ method_inst ->
 717     mkStrLit s                                  `thenM` \ string_lit ->
 718     returnM (GenInst [method_inst]
 719                      (mkHsApp (L (instLocSpan loc)
 720                                  (HsVar (instToId method_inst))) string_lit))
 721
 722 --------------------- Dictionaries ------------------------
 723 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
 724   = do  { mb_result <- lookupPred pred
 725         ; case mb_result of {
 726             Nothing -> return NoInstance ;
 727             Just (dfun_id, mb_inst_tys) -> do
 728
 729     { use_stage <- getStage
 730     ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 731                       (topIdLvl dfun_id) use_stage
 732
 733         -- It's possible that not all the tyvars are in
 734         -- the substitution, tenv. For example:
 735         --      instance C X a => D X where ...
 736         -- (presumably there's a functional dependency in class C)
 737         -- Hence mb_inst_tys :: Either TyVar TcType
 738
 739     ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
 740           inst_tv (Right ty) = return ty
 741     ; tys <- mappM inst_tv mb_inst_tys
 742     ; let
 743         (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
 744         src_loc    = instLocSpan loc
 745         dfun       = HsVar dfun_id
 746     ; if null theta then
 747         returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
 748       else do
 749     { (dicts, dict_app) <- instCallDicts loc theta
 750     ; let co_fn = dict_app <.> mkWpTyApps tys
 751     ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
 752     }}}}
 753
 754 ---------------
 755 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
 756 -- Look up a class constraint in the instance environment
 757 lookupPred pred@(ClassP clas tys)
 758   = do  { eps     <- getEps
 759         ; tcg_env <- getGblEnv
 760         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 761         ; case lookupInstEnv inst_envs clas tys of {
 762             ([(ispec, inst_tys)], [])
 763                 -> do   { let dfun_id = is_dfun ispec
 764                         ; traceTc (text "lookupInst success" <+>
 765                                    vcat [text "dict" <+> ppr pred,
 766                                          text "witness" <+> ppr dfun_id
 767                                          <+> ppr (idType dfun_id) ])
 768                                 -- Record that this dfun is needed
 769                         ; record_dfun_usage dfun_id
 770                         ; return (Just (dfun_id, inst_tys)) } ;
 771
 772             (matches, unifs)
 773                 -> do   { traceTc (text "lookupInst fail" <+>
 774                                    vcat [text "dict" <+> ppr pred,
 775                                          text "matches" <+> ppr matches,
 776                                          text "unifs" <+> ppr unifs])
 777                 -- In the case of overlap (multiple matches) we report
 778                 -- NoInstance here.  That has the effect of making the
 779                 -- context-simplifier return the dict as an irreducible one.
 780                 -- Then it'll be given to addNoInstanceErrs, which will do another
 781                 -- lookupInstEnv to get the detailed info about what went wrong.
 782                         ; return Nothing }
 783         }}
 784
 785 lookupPred ip_pred = return Nothing     -- Implicit parameters
 786
 787 record_dfun_usage dfun_id
 788   = do  { hsc_env <- getTopEnv
 789         ; let  dfun_name = idName dfun_id
 790                dfun_mod  = nameModule dfun_name
 791         ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 792              modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 793           then return () -- internal, or in another package
 794            else do { tcg_env <- getGblEnv
 795                    ; updMutVar (tcg_inst_uses tcg_env)
 796                                (`addOneToNameSet` idName dfun_id) }}
 797
 798
 799 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 800 -- Gets both the external-package inst-env
 801 -- and the home-pkg inst env (includes module being compiled)
 802 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 803                      return (eps_inst_env eps, tcg_inst_env env) }
 804 \end{code}
 805
 806
 807
 808 %************************************************************************
 809 %*                                                                      *
 810                 Re-mappable syntax
 811 %*                                                                      *
 812 %************************************************************************
 813
 814 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 815 a do-expression.  We have to find (>>) in the current environment, which is
 816 done by the rename. Then we have to check that it has the same type as
 817 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 818 this:
 819
 820   (>>) :: HB m n mn => m a -> n b -> mn b
 821
 822 So the idea is to generate a local binding for (>>), thus:
 823
 824         let then72 :: forall a b. m a -> m b -> m b
 825             then72 = ...something involving the user's (>>)...
 826         in
 827         ...the do-expression...
 828
 829 Now the do-expression can proceed using then72, which has exactly
 830 the expected type.
 831
 832 In fact tcSyntaxName just generates the RHS for then72, because we only
 833 want an actual binding in the do-expression case. For literals, we can
 834 just use the expression inline.
 835
 836 \begin{code}
 837 tcSyntaxName :: InstOrigin
 838              -> TcType                  -- Type to instantiate it at
 839              -> (Name, HsExpr Name)     -- (Standard name, user name)
 840              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 841 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 842 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 843 -- So we do not call it from lookupInst, which is called from tcSimplify
 844
 845 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 846   | std_nm == user_nm
 847   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 848     returnM (std_nm, HsVar id)
 849
 850 tcSyntaxName orig ty (std_nm, user_nm_expr)
 851   = tcLookupId std_nm           `thenM` \ std_id ->
 852     let
 853         -- C.f. newMethodAtLoc
 854         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 855         sigma1          = substTyWith [tv] [ty] tau
 856         -- Actually, the "tau-type" might be a sigma-type in the
 857         -- case of locally-polymorphic methods.
 858     in
 859     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)       $
 860
 861         -- Check that the user-supplied thing has the
 862         -- same type as the standard one.
 863         -- Tiresome jiggling because tcCheckSigma takes a located expression
 864     getSrcSpanM                                 `thenM` \ span ->
 865     tcPolyExpr (L span user_nm_expr) sigma1     `thenM` \ expr ->
 866     returnM (std_nm, unLoc expr)
 867
 868 syntaxNameCtxt name orig ty tidy_env
 869   = getInstLoc orig             `thenM` \ inst_loc ->
 870     let
 871         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 872                                 ptext SLIT("(needed by a syntactic construct)"),
 873                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 874                     nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
 875     in
 876     returnM (tidy_env, msg)
 877 \end{code}