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