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