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