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