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