ghc/compiler/typecheck/Inst.lhs

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