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