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, mkTopTyVarSubst )
  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, unLoc, 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
 281               -> TyVarDetails   -- Use this for the existential tyvars
 282                                 -- ExistTv when pattern-matching,
 283                                 -- VanillaTv at a call of the constructor
 284               -> DataCon
 285               -> TcM ([TcType], -- Types to instantiate at
 286                       [Inst],   -- Existential dictionaries to apply to
 287                       [TcType], -- Argument types of constructor
 288                       TcType,   -- Result type
 289                       [TyVar])  -- Existential tyvars
 290 tcInstDataCon orig ex_tv_details data_con
 291   = let
 292         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 293              -- We generate constraints for the stupid theta even when
 294              -- pattern matching (as the Report requires)
 295     in
 296     mappM (tcInstTyVar VanillaTv)     tvs       `thenM` \ tvs' ->
 297     mappM (tcInstTyVar ex_tv_details) ex_tvs    `thenM` \ ex_tvs' ->
 298     let
 299         tv_tys'    = mkTyVarTys tvs'
 300         ex_tv_tys' = mkTyVarTys ex_tvs'
 301         all_tys'   = tv_tys' ++ ex_tv_tys'
 302
 303         tenv          = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys'
 304         stupid_theta' = substTheta tenv stupid_theta
 305         ex_theta'     = substTheta tenv ex_theta
 306         arg_tys'      = map (substTy tenv) arg_tys
 307         result_ty'    = mkTyConApp tycon tv_tys'
 308     in
 309     newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
 310     newDicts orig ex_theta'     `thenM` \ ex_dicts ->
 311
 312         -- Note that we return the stupid theta *only* in the LIE;
 313         -- we don't otherwise use it at all
 314     extendLIEs stupid_dicts     `thenM_`
 315
 316     returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs')
 317
 318 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
 319 newMethodFromName origin ty name
 320   = tcLookupId name             `thenM` \ id ->
 321         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 322         -- always a class op, but with -fno-implicit-prelude GHC is
 323         -- meant to find whatever thing is in scope, and that may
 324         -- be an ordinary function.
 325     getInstLoc origin           `thenM` \ loc ->
 326     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 327     extendLIE inst              `thenM_`
 328     returnM (instToId inst)
 329
 330 newMethodWithGivenTy orig id tys theta tau
 331   = getInstLoc orig                     `thenM` \ loc ->
 332     newMethod loc id tys theta tau      `thenM` \ inst ->
 333     extendLIE inst                      `thenM_`
 334     returnM (instToId inst)
 335
 336 --------------------------------------------
 337 -- tcInstClassOp, and newMethod do *not* drop the
 338 -- Inst into the LIE; they just returns the Inst
 339 -- This is important because they are used by TcSimplify
 340 -- to simplify Insts
 341
 342 -- NB: the kind of the type variable to be instantiated
 343 --     might be a sub-kind of the type to which it is applied,
 344 --     notably when the latter is a type variable of kind ??
 345 --     Hence the call to checkKind
 346 -- A worry: is this needed anywhere else?
 347 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 348 tcInstClassOp inst_loc sel_id tys
 349   = let
 350         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 351         rho_ty       = ASSERT( length tyvars == length tys )
 352                        substTyWith tyvars tys rho
 353         (preds,tau)  = tcSplitPhiTy rho_ty
 354     in
 355     zipWithM_ checkKind tyvars tys      `thenM_`
 356     newMethod inst_loc sel_id tys preds tau
 357
 358 checkKind :: TyVar -> TcType -> TcM ()
 359 -- Ensure that the type has a sub-kind of the tyvar
 360 checkKind tv ty
 361   = do  { ty1 <- zonkTcType ty
 362         ; if typeKind ty1 `isSubKind` tyVarKind tv
 363           then return ()
 364           else do
 365         { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
 366         ; tv1 <- tcInstTyVar VanillaTv tv
 367         ; unifyTauTy (mkTyVarTy tv1) ty1 }}
 368
 369
 370 ---------------------------
 371 newMethod inst_loc id tys theta tau
 372   = newUnique           `thenM` \ new_uniq ->
 373     let
 374         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 375         inst    = Method meth_id id tys theta tau inst_loc
 376         loc     = instLocSrcLoc inst_loc
 377     in
 378     returnM inst
 379 \end{code}
 380
 381 In newOverloadedLit we convert directly to an Int or Integer if we
 382 know that's what we want.  This may save some time, by not
 383 temporarily generating overloaded literals, but it won't catch all
 384 cases (the rest are caught in lookupInst).
 385
 386 \begin{code}
 387 newOverloadedLit :: InstOrigin
 388                  -> HsOverLit
 389                  -> TcType
 390                  -> TcM (LHsExpr TcId)
 391 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 392   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable syntax.
 393                                 -- Reason: tcSyntaxName does unification
 394                                 -- which is very inconvenient in tcSimplify
 395                                 -- ToDo: noLoc sadness
 396   = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi)   `thenM` \ (_,expr) ->
 397     mkIntegerLit i                                              `thenM` \ integer_lit ->
 398     returnM (mkHsApp (noLoc expr) integer_lit)
 399         -- The mkHsApp will get the loc from the literal
 400   | Just expr <- shortCutIntLit i expected_ty
 401   = returnM expr
 402
 403   | otherwise
 404   = newLitInst orig lit expected_ty
 405
 406 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 407   | fr /= fromRationalName      -- c.f. HsIntegral case
 408   = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr)  `thenM` \ (_,expr) ->
 409     mkRatLit r                                                  `thenM` \ rat_lit ->
 410     returnM (mkHsApp (noLoc expr) rat_lit)
 411         -- The mkHsApp will get the loc from the literal
 412
 413   | Just expr <- shortCutFracLit r expected_ty
 414   = returnM expr
 415
 416   | otherwise
 417   = newLitInst orig lit expected_ty
 418
 419 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
 420 newLitInst orig lit expected_ty
 421   = getInstLoc orig             `thenM` \ loc ->
 422     newUnique                   `thenM` \ new_uniq ->
 423     let
 424         lit_inst = LitInst lit_id lit expected_ty loc
 425         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 426     in
 427     extendLIE lit_inst          `thenM_`
 428     returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
 429
 430 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId)     -- Returns noLoc'd result :-)
 431 shortCutIntLit i ty
 432   | isIntTy ty && inIntRange i          -- Short cut for Int
 433   = Just (noLoc (HsLit (HsInt i)))
 434   | isIntegerTy ty                      -- Short cut for Integer
 435   = Just (noLoc (HsLit (HsInteger i ty)))
 436   | otherwise = Nothing
 437
 438 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId)   -- Returns noLoc'd result :-)
 439 shortCutFracLit f ty
 440   | isFloatTy ty
 441   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 442   | isDoubleTy ty
 443   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 444   | otherwise = Nothing
 445
 446 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 447 mkIntegerLit i
 448   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 449     getSrcSpanM                 `thenM` \ span ->
 450     returnM (L span $ HsLit (HsInteger i integer_ty))
 451
 452 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 453 mkRatLit r
 454   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 455     getSrcSpanM                 `thenM` \ span ->
 456     returnM (L span $ HsLit (HsRat r rat_ty))
 457 \end{code}
 458
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsection{Zonking}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 Zonking makes sure that the instance types are fully zonked,
 467 but doesn't do the same for any of the Ids in an Inst.  There's no
 468 need, and it's a lot of extra work.
 469
 470 \begin{code}
 471 zonkInst :: Inst -> TcM Inst
 472 zonkInst (Dict id pred loc)
 473   = zonkTcPredType pred                 `thenM` \ new_pred ->
 474     returnM (Dict id new_pred loc)
 475
 476 zonkInst (Method m id tys theta tau loc)
 477   = zonkId id                   `thenM` \ new_id ->
 478         -- Essential to zonk the id in case it's a local variable
 479         -- Can't use zonkIdOcc because the id might itself be
 480         -- an InstId, in which case it won't be in scope
 481
 482     zonkTcTypes tys             `thenM` \ new_tys ->
 483     zonkTcThetaType theta       `thenM` \ new_theta ->
 484     zonkTcType tau              `thenM` \ new_tau ->
 485     returnM (Method m new_id new_tys new_theta new_tau loc)
 486
 487 zonkInst (LitInst id lit ty loc)
 488   = zonkTcType ty                       `thenM` \ new_ty ->
 489     returnM (LitInst id lit new_ty loc)
 490
 491 zonkInsts insts = mappM zonkInst insts
 492 \end{code}
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection{Printing}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 502 relevant in error messages.
 503
 504 \begin{code}
 505 instance Outputable Inst where
 506     ppr inst = pprInst inst
 507
 508 pprDictsTheta :: [Inst] -> SDoc
 509 -- Print in type-like fashion (Eq a, Show b)
 510 pprDictsTheta dicts = pprTheta (map dictPred dicts)
 511
 512 pprDictsInFull :: [Inst] -> SDoc
 513 -- Print in type-like fashion, but with source location
 514 pprDictsInFull dicts
 515   = vcat (map go dicts)
 516   where
 517     go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
 518
 519 pprInsts :: [Inst] -> SDoc
 520 -- Debugging: print the evidence :: type
 521 pprInsts insts  = brackets (interpp'SP insts)
 522
 523 pprInst, pprInstInFull :: Inst -> SDoc
 524 -- Debugging: print the evidence :: type
 525 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
 526 pprInst (Dict id pred loc)      = ppr id <+> dcolon <+> pprPred pred
 527
 528 pprInst m@(Method inst_id id tys theta tau loc)
 529   = ppr inst_id <+> dcolon <+>
 530         braces (sep [ppr id <+> ptext SLIT("at"),
 531                      brackets (sep (map pprParendType tys))])
 532
 533 pprInstInFull inst
 534   = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
 535
 536 pprDFuns :: [DFunId] -> SDoc
 537 -- Prints the dfun as an instance declaration
 538 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
 539                         2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
 540                                                            pprClassPred clas tys])
 541                       | dfun <- dfuns
 542                       , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
 543         -- Print without the for-all, which the programmer doesn't write
 544
 545 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 546
 547 tidyInst :: TidyEnv -> Inst -> Inst
 548 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 549 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 550 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 551
 552 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 553 -- This function doesn't assume that the tyvars are in scope
 554 -- so it works like tidyOpenType, returning a TidyEnv
 555 tidyMoreInsts env insts
 556   = (env', map (tidyInst env') insts)
 557   where
 558     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 559
 560 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 561 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 562
 563 showLIE :: SDoc -> TcM ()       -- Debugging
 564 showLIE str
 565   = do { lie_var <- getLIEVar ;
 566          lie <- readMutVar lie_var ;
 567          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 568 \end{code}
 569
 570
 571 %************************************************************************
 572 %*                                                                      *
 573         Extending the instance environment
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 \begin{code}
 578 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 579   -- Add new locally-defined instances
 580 tcExtendLocalInstEnv dfuns thing_inside
 581  = do { traceDFuns dfuns
 582       ; env <- getGblEnv
 583       ; dflags  <- getDOpts
 584       ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
 585       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 586                          tcg_inst_env = inst_env' }
 587       ; setGblEnv env' thing_inside }
 588
 589 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 590 -- Check that the proposed new instance is OK,
 591 -- and then add it to the home inst env
 592 addInst dflags home_ie dfun
 593   = do  {       -- Load imported instances, so that we report
 594                 -- duplicates correctly
 595           pkg_ie  <- loadImportedInsts cls tys
 596
 597                 -- Check functional dependencies
 598         ; case checkFunDeps (pkg_ie, home_ie) dfun of
 599                 Just dfuns -> funDepErr dfun dfuns
 600                 Nothing    -> return ()
 601
 602                 -- Check for duplicate instance decls
 603         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
 604               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 605                                         isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
 606                 -- Find memebers of the match list which
 607                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 608         ; case dup_dfuns of
 609             dup_dfun : _ -> dupInstErr dfun dup_dfun
 610             []           -> return ()
 611
 612                 -- OK, now extend the envt
 613         ; return (extendInstEnv home_ie dfun) }
 614   where
 615     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 616
 617 traceDFuns dfuns
 618   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 619   where
 620     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 621
 622 funDepErr dfun dfuns
 623   = addDictLoc dfun $
 624     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 625                2 (pprDFuns (dfun:dfuns)))
 626 dupInstErr dfun dup_dfun
 627   = addDictLoc dfun $
 628     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 629                2 (pprDFuns [dfun, dup_dfun]))
 630
 631 addDictLoc dfun thing_inside
 632   = addSrcSpan (mkSrcSpan loc loc) thing_inside
 633   where
 634    loc = getSrcLoc dfun
 635 \end{code}
 636
 637 %************************************************************************
 638 %*                                                                      *
 639 \subsection{Looking up Insts}
 640 %*                                                                      *
 641 %************************************************************************
 642
 643 \begin{code}
 644 data LookupInstResult s
 645   = NoInstance
 646   | SimpleInst (LHsExpr TcId)           -- Just a variable, type application, or literal
 647   | GenInst    [Inst] (LHsExpr TcId)    -- The expression and its needed insts
 648
 649 lookupInst :: Inst -> TcM (LookupInstResult s)
 650 -- It's important that lookupInst does not put any new stuff into
 651 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 652 -- the LookupInstResult, where they can be further processed by tcSimplify
 653
 654
 655 -- Methods
 656
 657 lookupInst inst@(Method _ id tys theta _ loc)
 658   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 659     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
 660   where
 661     span = instLocSrcSpan loc
 662
 663 -- Literals
 664
 665 -- Look for short cuts first: if the literal is *definitely* a
 666 -- int, integer, float or a double, generate the real thing here.
 667 -- This is essential  (see nofib/spectral/nucleic).
 668 -- [Same shortcut as in newOverloadedLit, but we
 669 --  may have done some unification by now]
 670
 671
 672 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 673   | Just expr <- shortCutIntLit i ty
 674   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 675                                         -- expr may be a constructor application
 676   | otherwise
 677   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 678     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 679     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 680     mkIntegerLit i                              `thenM` \ integer_lit ->
 681     returnM (GenInst [method_inst]
 682                      (mkHsApp (L (instLocSrcSpan loc)
 683                                  (HsVar (instToId method_inst))) integer_lit))
 684
 685 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 686   | Just expr <- shortCutFracLit f ty
 687   = returnM (GenInst [] expr)
 688
 689   | otherwise
 690   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 691     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 692     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 693     mkRatLit f                                  `thenM` \ rat_lit ->
 694     returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
 695                                                (HsVar (instToId method_inst))) rat_lit))
 696
 697 -- Dictionaries
 698 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 699   = do  { pkg_ie <- loadImportedInsts clas tys
 700                 -- Suck in any instance decls that may be relevant
 701         ; tcg_env <- getGblEnv
 702         ; dflags  <- getDOpts
 703         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 704             ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 705             (matches, unifs)              -> do
 706         { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
 707                                                     text "matches" <+> ppr matches,
 708                                                     text "unifs" <+> ppr unifs])
 709         ; return NoInstance } } }
 710                 -- In the case of overlap (multiple matches) we report
 711                 -- NoInstance here.  That has the effect of making the
 712                 -- context-simplifier return the dict as an irreducible one.
 713                 -- Then it'll be given to addNoInstanceErrs, which will do another
 714                 -- lookupInstEnv to get the detailed info about what went wrong.
 715
 716 lookupInst (Dict _ _ _) = returnM NoInstance
 717
 718 -----------------
 719 instantiate_dfun tenv dfun_id pred loc
 720   = traceTc (text "lookupInst success" <+>
 721                 vcat [text "dict" <+> ppr pred,
 722                       text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
 723         -- Record that this dfun is needed
 724     record_dfun_usage dfun_id           `thenM_`
 725
 726         -- It's possible that not all the tyvars are in
 727         -- the substitution, tenv. For example:
 728         --      instance C X a => D X where ...
 729         -- (presumably there's a functional dependency in class C)
 730         -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 731     getStage                                            `thenM` \ use_stage ->
 732     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 733                     (topIdLvl dfun_id) use_stage                `thenM_`
 734     let
 735         (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 736         mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 737                            Just (DoneTy ty) -> returnM ty
 738                            Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 739                                                returnM (mkTyVarTy tc_tv)
 740     in
 741     mappM mk_ty_arg tyvars      `thenM` \ ty_args ->
 742     let
 743         dfun_rho   = substTy (mkTopTyVarSubst tyvars ty_args) rho
 744                 -- Since the tyvars are freshly made,
 745                 -- they cannot possibly be captured by
 746                 -- any existing for-alls.  Hence mkTopTyVarSubst
 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 external-package inst-env
 770 -- and the home-pkg inst env (includes module being compiled)
 771 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 772                      return (eps_inst_env eps, tcg_inst_env env) }
 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, HsExpr Name)     -- (Standard name, user name)
 810              -> TcM (Name, HsExpr 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, HsVar user_nm)
 816   | std_nm == user_nm
 817   = 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         sigma1          = 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 sigma1)       $
 829
 830         -- Check that the user-supplied thing has the
 831         -- same type as the standard one.
 832         -- Tiresome jiggling because tcCheckSigma takes a located expression
 833     getSrcSpanM                                 `thenM` \ span ->
 834     tcCheckSigma (L span user_nm_expr) sigma1   `thenM` \ expr ->
 835     returnM (std_nm, unLoc expr)
 836
 837 tcStdSyntaxName :: InstOrigin
 838                 -> TcType                       -- Type to instantiate it at
 839                 -> Name                         -- Standard name
 840                 -> TcM (Name, HsExpr TcId)      -- (Standard name, suitable expression)
 841
 842 tcStdSyntaxName orig ty std_nm
 843   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 844     returnM (std_nm, HsVar id)
 845
 846 syntaxNameCtxt name orig ty tidy_env
 847   = getInstLoc orig             `thenM` \ inst_loc ->
 848     let
 849         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 850                                 ptext SLIT("(needed by a syntactic construct)"),
 851                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 852                     nest 2 (pprInstLoc inst_loc)]
 853     in
 854     returnM (tidy_env, msg)
 855 \end{code}