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