compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcInstDecls: Typechecking instance declarations
   7
   8 \begin{code}
   9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
  10
  11 import HsSyn
  12 import TcBinds
  13 import TcTyClsDecls
  14 import TcClassDcl
  15 import TcRnMonad
  16 import TcMType
  17 import TcType
  18 import Inst
  19 import InstEnv
  20 import FamInst
  21 import FamInstEnv
  22 import TcDeriv
  23 import TcEnv
  24 import RnEnv    ( lookupImportedName )
  25 import TcHsType
  26 import TcUnify
  27 import TcSimplify
  28 import Type
  29 import Coercion
  30 import TyCon
  31 import TypeRep
  32 import DataCon
  33 import Class
  34 import Var
  35 import Id
  36 import MkId
  37 import Name
  38 import NameSet
  39 import DynFlags
  40 import SrcLoc
  41 import Util
  42 import Outputable
  43 import Maybes
  44 import Bag
  45 import BasicTypes
  46 import HscTypes
  47 import FastString
  48
  49 import Data.Maybe
  50 import Control.Monad
  51 import Data.List
  52
  53 #include "HsVersions.h"
  54 \end{code}
  55
  56 Typechecking instance declarations is done in two passes. The first
  57 pass, made by @tcInstDecls1@, collects information to be used in the
  58 second pass.
  59
  60 This pre-processed info includes the as-yet-unprocessed bindings
  61 inside the instance declaration.  These are type-checked in the second
  62 pass, when the class-instance envs and GVE contain all the info from
  63 all the instance and value decls.  Indeed that's the reason we need
  64 two passes over the instance decls.
  65
  66
  67 Note [How instance declarations are translated]
  68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  69 Here is how we translation instance declarations into Core
  70
  71 Running example:
  72         class C a where
  73            op1, op2 :: Ix b => a -> b -> b
  74            op2 = <dm-rhs>
  75
  76         instance C a => C [a]
  77            {-# INLINE [2] op1 #-}
  78            op1 = <rhs>
  79 ===>
  80         -- Method selectors
  81         op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
  82         op1 = ...
  83         op2 = ...
  84
  85         -- Default methods get the 'self' dictionary as argument
  86         -- so they can call other methods at the same type
  87         -- Default methods get the same type as their method selector
  88         $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
  89         $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
  90                -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
  91                -- Note [Tricky type variable scoping]
  92
  93         -- A top-level definition for each instance method
  94         -- Here op1_i, op2_i are the "instance method Ids"
  95         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
  96         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
  97         op1_i = /\a. \(d:C a).
  98                let local_op1 :: forall a. (C a, C [a])
  99                              => forall b. Ix b => [a] -> b -> b
 100                      -- Note [Subtle interaction of recursion and overlap]
 101                    local_op1 = <rhs>
 102                      -- Source code; run the type checker on this
 103                      -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
 104                      -- Note [Tricky type variable scoping]
 105
 106                in local_op1 a d (df_i a d)
 107
 108         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
 109
 110         -- The dictionary function itself
 111         {-# INLINE df_i #-}     -- Always inline dictionary functions
 112         df_i :: forall a. C a -> C [a]
 113         df_i = /\a. \d:C a. letrec d' = MkC (op1_i  a   d)
 114                                             ($dmop2 [a] d')
 115                             in d'
 116                 -- But see Note [Default methods in instances]
 117                 -- We can't apply the type checker to the default-method call
 118
 119 * The dictionary function itself is inlined as vigorously as we
 120   possibly can, so that we expose that dictionary constructor to
 121   selectors as much as poss.  That is why the op_i stuff is in
 122   *separate* bindings, so that the df_i binding is small enough
 123   to inline.  See Note [Inline dfuns unconditionally].
 124
 125 * Note that df_i may be mutually recursive with both op1_i and op2_i.
 126   It's crucial that df_i is not chosen as the loop breaker, even
 127   though op1_i has a (user-specified) INLINE pragma.
 128   Not even once!  Else op1_i, op2_i may be inlined into df_i.
 129
 130 * Instead the idea is to inline df_i into op1_i, which may then select
 131   methods from the MkC record, and thereby break the recursion with
 132   df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
 133   the same type, it won't mention df_i, so there won't be recursion in
 134   the first place.)
 135
 136 * If op1_i is marked INLINE by the user there's a danger that we won't
 137   inline df_i in it, and that in turn means that (since it'll be a
 138   loop-breaker because df_i isn't), op1_i will ironically never be
 139   inlined.  We need to fix this somehow -- perhaps allowing inlining
 140   of INLINE funcitons inside other INLINE functions.
 141
 142 Note [Subtle interaction of recursion and overlap]
 143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 144 Consider this
 145   class C a where { op1,op2 :: a -> a }
 146   instance C a => C [a] where
 147     op1 x = op2 x ++ op2 x
 148     op2 x = ...
 149   intance C [Int] where
 150     ...
 151
 152 When type-checking the C [a] instance, we need a C [a] dictionary (for
 153 the call of op2).  If we look up in the instance environment, we find
 154 an overlap.  And in *general* the right thing is to complain (see Note
 155 [Overlapping instances] in InstEnv).  But in *this* case it's wrong to
 156 complain, because we just want to delegate to the op2 of this same
 157 instance.
 158
 159 Why is this justified?  Because we generate a (C [a]) constraint in
 160 a context in which 'a' cannot be instantiated to anything that matches
 161 other overlapping instances, or else we would not be excecuting this
 162 version of op1 in the first place.
 163
 164 It might even be a bit disguised:
 165
 166   nullFail :: C [a] => [a] -> [a]
 167   nullFail x = op2 x ++ op2 x
 168
 169   instance C a => C [a] where
 170     op1 x = nullFail x
 171
 172 Precisely this is used in package 'regex-base', module Context.hs.
 173 See the overlapping instances for RegexContext, and the fact that they
 174 call 'nullFail' just like the example above.  The DoCon package also
 175 does the same thing; it shows up in module Fraction.hs
 176
 177 Conclusion: when typechecking the methods in a C [a] instance, we want
 178 to have C [a] available.  That is why we have the strange local let in
 179 the definition of op1_i in the example above.  We can typecheck the
 180 defintion of local_op1, and then supply the "this" argument via an
 181 explicit call to the dfun (which in turn will be inlined).
 182
 183 Note [Tricky type variable scoping]
 184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 185 In our example
 186         class C a where
 187            op1, op2 :: Ix b => a -> b -> b
 188            op2 = <dm-rhs>
 189
 190         instance C a => C [a]
 191            {-# INLINE [2] op1 #-}
 192            op1 = <rhs>
 193
 194 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
 195 in scope in <rhs>.  In particular, we must make sure that 'b' is in
 196 scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
 197 which brings appropriate tyvars into scope. This happens for both
 198 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
 199 complained if 'b' is mentioned in <rhs>.
 200
 201 Note [Inline dfuns unconditionally]
 202 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 203 The code above unconditionally inlines dict funs.  Here's why.
 204 Consider this program:
 205
 206     test :: Int -> Int -> Bool
 207     test x y = (x,y) == (y,x) || test y x
 208     -- Recursive to avoid making it inline.
 209
 210 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 211 the code we end up with is good:
 212
 213     Test.$wtest =
 214         \r -> case ==# [ww ww1] of wild {
 215                 PrelBase.False -> Test.$wtest ww1 ww;
 216                 PrelBase.True ->
 217                   case ==# [ww1 ww] of wild1 {
 218                     PrelBase.False -> Test.$wtest ww1 ww;
 219                     PrelBase.True -> PrelBase.True [];
 220                   };
 221             };
 222     Test.test = \r [w w1]
 223             case w of w2 {
 224               PrelBase.I# ww ->
 225                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 226             };
 227
 228 If we don't inline the dfun, the code is not nearly as good:
 229
 230     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 231               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 232             };
 233
 234     Test.$wtest =
 235         \r [ww ww1]
 236             let { y = PrelBase.I#! [ww1]; } in
 237             let { x = PrelBase.I#! [ww]; } in
 238             let { sat_slx = PrelTup.(,)! [y x]; } in
 239             let { sat_sly = PrelTup.(,)! [x y];
 240             } in
 241               case == sat_sly sat_slx of wild {
 242                 PrelBase.False -> Test.$wtest ww1 ww;
 243                 PrelBase.True -> PrelBase.True [];
 244               };
 245
 246     Test.test =
 247         \r [w w1]
 248             case w of w2 {
 249               PrelBase.I# ww ->
 250                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 251             };
 252
 253 Why didn't GHC inline $fEq in those days?  Because it looked big:
 254
 255     PrelTup.zdfEqZ1T{-rcX-}
 256         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 257             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 258             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 259             let {
 260               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 261               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 262             let {
 263               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 264               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 265             let {
 266               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 267               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 268                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 269                              case ds{-rf5-}
 270                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 271                              case ds1{-rf4-}
 272                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 273                              PrelBase.zaza{-r4e-}
 274                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 275                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 276                              }
 277                              } } in
 278             let {
 279               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 280               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 281                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 282                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 283             } in
 284               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 285
 286 and it's not as bad as it seems, because it's further dramatically
 287 simplified: only zeze2 is extracted and its body is simplified.
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Extracting instance decls}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 Gather up the instance declarations from their various sources
 297
 298 \begin{code}
 299 tcInstDecls1    -- Deal with both source-code and imported instance decls
 300    :: [LTyClDecl Name]          -- For deriving stuff
 301    -> [LInstDecl Name]          -- Source code instance decls
 302    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
 303    -> TcM (TcGblEnv,            -- The full inst env
 304            [InstInfo Name],     -- Source-code instance decls to process;
 305                                 -- contains all dfuns for this module
 306            HsValBinds Name)     -- Supporting bindings for derived instances
 307
 308 tcInstDecls1 tycl_decls inst_decls deriv_decls
 309   = checkNoErrs $
 310     do {        -- Stop if addInstInfos etc discovers any errors
 311                 -- (they recover, so that we get more than one error each
 312                 -- round)
 313
 314                 -- (1) Do class and family instance declarations
 315        ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
 316        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
 317        ; idx_tycons        <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
 318
 319        ; let { (local_info,
 320                 at_tycons_s)   = unzip local_info_tycons
 321              ; at_idx_tycon    = concat at_tycons_s ++ idx_tycons
 322              ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
 323              ; implicit_things = concatMap implicitTyThings at_idx_tycon
 324              }
 325
 326                 -- (2) Add the tycons of indexed types and their implicit
 327                 --     tythings to the global environment
 328        ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
 329
 330                 -- (3) Instances from generic class declarations
 331        ; generic_inst_info <- getGenericInstances clas_decls
 332
 333                 -- Next, construct the instance environment so far, consisting
 334                 -- of
 335                 --   a) local instance decls
 336                 --   b) generic instances
 337                 --   c) local family instance decls
 338        ; addInsts local_info         $ do {
 339        ; addInsts generic_inst_info  $ do {
 340        ; addFamInsts at_idx_tycon    $ do {
 341
 342                 -- (4) Compute instances from "deriving" clauses;
 343                 -- This stuff computes a context for the derived instance
 344                 -- decl, so it needs to know about all the instances possible
 345                 -- NB: class instance declarations can contain derivings as
 346                 --     part of associated data type declarations
 347          failIfErrsM            -- If the addInsts stuff gave any errors, don't
 348                                 -- try the deriving stuff, becuase that may give
 349                                 -- more errors still
 350        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
 351                                                       deriv_decls
 352        ; addInsts deriv_inst_info   $ do {
 353
 354        ; gbl_env <- getGblEnv
 355        ; return (gbl_env,
 356                   generic_inst_info ++ deriv_inst_info ++ local_info,
 357                   deriv_binds)
 358     }}}}}}
 359   where
 360     -- Make sure that toplevel type instance are not for associated types.
 361     -- !!!TODO: Need to perform this check for the TyThing of type functions,
 362     --          too.
 363     tcIdxTyInstDeclTL ldecl@(L loc decl) =
 364       do { tything <- tcFamInstDecl ldecl
 365          ; setSrcSpan loc $
 366              when (isAssocFamily tything) $
 367                addErr $ assocInClassErr (tcdName decl)
 368          ; return tything
 369          }
 370     isAssocFamily (ATyCon tycon) =
 371       case tyConFamInst_maybe tycon of
 372         Nothing       -> panic "isAssocFamily: no family?!?"
 373         Just (fam, _) -> isTyConAssoc fam
 374     isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
 375
 376 assocInClassErr :: Name -> SDoc
 377 assocInClassErr name =
 378   ptext (sLit "Associated type") <+> quotes (ppr name) <+>
 379   ptext (sLit "must be inside a class instance")
 380
 381 addInsts :: [InstInfo Name] -> TcM a -> TcM a
 382 addInsts infos thing_inside
 383   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 384
 385 addFamInsts :: [TyThing] -> TcM a -> TcM a
 386 addFamInsts tycons thing_inside
 387   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
 388   where
 389     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
 390     mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
 391                                                     (ppr tything)
 392 \end{code}
 393
 394 \begin{code}
 395 tcLocalInstDecl1 :: LInstDecl Name
 396                  -> TcM (InstInfo Name, [TyThing])
 397         -- A source-file instance declaration
 398         -- Type-check all the stuff before the "where"
 399         --
 400         -- We check for respectable instance type, and context
 401 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
 402   = setSrcSpan loc                      $
 403     addErrCtxt (instDeclCtxt1 poly_ty)  $
 404
 405     do  { is_boot <- tcIsHsBoot
 406         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
 407                   badBootDeclErr
 408
 409         ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 410
 411         -- Now, check the validity of the instance.
 412         ; (clas, inst_tys) <- checkValidInstHead tau
 413         ; checkValidInstance tyvars theta clas inst_tys
 414
 415         -- Next, process any associated types.
 416         ; idx_tycons <- recoverM (return []) $
 417                      do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
 418                         ; checkValidAndMissingATs clas (tyvars, inst_tys)
 419                                                   (zip ats idx_tycons)
 420                         ; return idx_tycons }
 421
 422         -- Finally, construct the Core representation of the instance.
 423         -- (This no longer includes the associated types.)
 424         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
 425                 -- Dfun location is that of instance *header*
 426         ; overlap_flag <- getOverlapFlag
 427         ; let (eq_theta,dict_theta) = partition isEqPred theta
 428               theta'         = eq_theta ++ dict_theta
 429               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
 430               ispec          = mkLocalInstance dfun overlap_flag
 431
 432         ; return (InstInfo { iSpec  = ispec,
 433                               iBinds = VanillaInst binds uprags },
 434                   idx_tycons)
 435         }
 436   where
 437     -- We pass in the source form and the type checked form of the ATs.  We
 438     -- really need the source form only to be able to produce more informative
 439     -- error messages.
 440     checkValidAndMissingATs :: Class
 441                             -> ([TyVar], [TcType])     -- instance types
 442                             -> [(LTyClDecl Name,       -- source form of AT
 443                                  TyThing)]             -- Core form of AT
 444                             -> TcM ()
 445     checkValidAndMissingATs clas inst_tys ats
 446       = do { -- Issue a warning for each class AT that is not defined in this
 447              -- instance.
 448            ; let class_ats   = map tyConName (classATs clas)
 449                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
 450                  omitted     = filterOut (`elemNameSet` defined_ats) class_ats
 451            ; warn <- doptM Opt_WarnMissingMethods
 452            ; mapM_ (warnTc warn . omittedATWarn) omitted
 453
 454              -- Ensure that all AT indexes that correspond to class parameters
 455              -- coincide with the types in the instance head.  All remaining
 456              -- AT arguments must be variables.  Also raise an error for any
 457              -- type instances that are not associated with this class.
 458            ; mapM_ (checkIndexes clas inst_tys) ats
 459            }
 460
 461     checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
 462 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
 463       checkIndexes' clas inst_tys hsAT
 464                     (tyConTyVars tycon,
 465                      snd . fromJust . tyConFamInst_maybe $ tycon)
 466     checkIndexes _ _ _ = panic "checkIndexes"
 467
 468     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
 469       = let atName = tcdName . unLoc $ hsAT
 470         in
 471         setSrcSpan (getLoc hsAT)       $
 472         addErrCtxt (atInstCtxt atName) $
 473         case find ((atName ==) . tyConName) (classATs clas) of
 474           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
 475           Just atDecl ->
 476             case assocTyConArgPoss_maybe atDecl of
 477               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
 478               Just poss ->
 479
 480                 -- The following is tricky!  We need to deal with three
 481                 -- complications: (1) The AT possibly only uses a subset of
 482                 -- the class parameters as indexes and those it uses may be in
 483                 -- a different order; (2) the AT may have extra arguments,
 484                 -- which must be type variables; and (3) variables in AT and
 485                 -- instance head will be different `Name's even if their
 486                 -- source lexemes are identical.
 487                 --
 488                 -- Re (1), `poss' contains a permutation vector to extract the
 489                 -- class parameters in the right order.
 490                 --
 491                 -- Re (2), we wrap the (permuted) class parameters in a Maybe
 492                 -- type and use Nothing for any extra AT arguments.  (First
 493                 -- equation of `checkIndex' below.)
 494                 --
 495                 -- Re (3), we replace any type variable in the AT parameters
 496                 -- that has the same source lexeme as some variable in the
 497                 -- instance types with the instance type variable sharing its
 498                 -- source lexeme.
 499                 --
 500                 let relevantInstTys = map (instTys !!) poss
 501                     instArgs        = map Just relevantInstTys ++
 502                                       repeat Nothing  -- extra arguments
 503                     renaming        = substSameTyVar atTvs instTvs
 504                 in
 505                 zipWithM_ checkIndex (substTys renaming atTys) instArgs
 506
 507     checkIndex ty Nothing
 508       | isTyVarTy ty         = return ()
 509       | otherwise            = addErrTc $ mustBeVarArgErr ty
 510     checkIndex ty (Just instTy)
 511       | ty `tcEqType` instTy = return ()
 512       | otherwise            = addErrTc $ wrongATArgErr ty instTy
 513
 514     listToNameSet = addListToNameSet emptyNameSet
 515
 516     substSameTyVar []       _            = emptyTvSubst
 517     substSameTyVar (tv:tvs) replacingTvs =
 518       let replacement = case find (tv `sameLexeme`) replacingTvs of
 519                         Nothing  -> mkTyVarTy tv
 520                         Just rtv -> mkTyVarTy rtv
 521           --
 522           tv1 `sameLexeme` tv2 =
 523             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
 524       in
 525       extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
 526 \end{code}
 527
 528
 529 %************************************************************************
 530 %*                                                                      *
 531       Type-checking instance declarations, pass 2
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 \begin{code}
 536 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
 537              -> TcM (LHsBinds Id, TcLclEnv)
 538 -- (a) From each class declaration,
 539 --      generate any default-method bindings
 540 -- (b) From each instance decl
 541 --      generate the dfun binding
 542
 543 tcInstDecls2 tycl_decls inst_decls
 544   = do  { -- (a) Default methods from class decls
 545           (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
 546                                     filter (isClassDecl.unLoc) tycl_decls
 547         ; tcExtendIdEnv (concat dm_ids_s) $ do
 548
 549           -- (b) instance declarations
 550         ; inst_binds_s <- mapM tcInstDecl2 inst_decls
 551
 552           -- Done
 553         ; let binds = unionManyBags dm_binds_s `unionBags`
 554                       unionManyBags inst_binds_s
 555         ; tcl_env <- getLclEnv -- Default method Ids in here
 556         ; return (binds, tcl_env) }
 557 \end{code}
 558
 559
 560 \begin{code}
 561 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
 562 -- Returns a binding for the dfun
 563
 564 ------------------------
 565 -- Derived newtype instances; surprisingly tricky!
 566 --
 567 --      class Show a => Foo a b where ...
 568 --      newtype N a = MkN (Tree [a]) deriving( Foo Int )
 569 --
 570 -- The newtype gives an FC axiom looking like
 571 --      axiom CoN a ::  N a :=: Tree [a]
 572 --   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
 573 --
 574 -- So all need is to generate a binding looking like:
 575 --      dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
 576 --      dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
 577 --                case df `cast` (Foo Int (sym (CoN a))) of
 578 --                   Foo _ op1 .. opn -> Foo ds op1 .. opn
 579 --
 580 -- If there are no superclasses, matters are simpler, because we don't need the case
 581 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
 582
 583 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
 584   = do  { let dfun_id      = instanceDFunId ispec
 585               rigid_info   = InstSkol
 586               origin       = SigOrigin rigid_info
 587               inst_ty      = idType dfun_id
 588         ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
 589                 -- inst_head_ty is a PredType
 590
 591         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
 592               (class_tyvars, sc_theta, _, _) = classBigSig cls
 593               cls_tycon = classTyCon cls
 594               sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
 595
 596               Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
 597               (nt_tycon, tc_args) = tcSplitTyConApp last_ty     -- Can't fail
 598               rep_ty              = newTyConInstRhs nt_tycon tc_args
 599
 600               rep_pred     = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
 601                                 -- In our example, rep_pred is (Foo Int (Tree [a]))
 602               the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 603                                 -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
 604
 605         ; inst_loc   <- getInstLoc origin
 606         ; sc_loc     <- getInstLoc InstScOrigin
 607         ; dfun_dicts <- newDictBndrs inst_loc theta
 608         ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
 609         ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
 610         ; rep_dict   <- newDictBndr inst_loc rep_pred
 611
 612         -- Figure out bindings for the superclass context from dfun_dicts
 613         -- Don't include this_dict in the 'givens', else
 614         -- wanted_sc_insts get bound by just selecting from this_dict!!
 615         ; sc_binds <- addErrCtxt superClassCtxt $
 616                       tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
 617
 618         ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
 619
 620         ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 621         ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 622
 623         ; return (unitBag $ noLoc $
 624                   AbsBinds  tvs (map instToVar dfun_dicts)
 625                             [(tvs, dfun_id, instToId this_dict, [])]
 626                             (dict_bind `consBag` sc_binds)) }
 627   where
 628       -----------------------
 629       --        make_coercion
 630       -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
 631       -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
 632       --        with kind (C s1 .. sm (T a1 .. ak)  :=:  C s1 .. sm <rep_ty>)
 633       --        where rep_ty is the (eta-reduced) type rep of T
 634       -- So we just replace T with CoT, and insert a 'sym'
 635       -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
 636
 637     make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 638         | Just co_con <- newTyConCo_maybe nt_tycon
 639         , let co = mkSymCoercion (mkTyConApp co_con tc_args)
 640         = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
 641         | otherwise     -- The newtype is transparent; no need for a cast
 642         = idHsWrapper
 643
 644       -----------------------
 645       --     (make_body C tys scs coreced_rep_dict)
 646       --                returns
 647       --     (case coerced_rep_dict of { C _ ops -> C scs ops })
 648       -- But if there are no superclasses, it returns just coerced_rep_dict
 649       -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
 650
 651     make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 652         | null sc_dicts         -- Case (a)
 653         = return coerced_rep_dict
 654         | otherwise             -- Case (b)
 655         = do { op_ids            <- newSysLocalIds (fsLit "op") op_tys
 656              ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
 657              ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
 658                                          pat_dicts = dummy_sc_dict_ids,
 659                                          pat_binds = emptyLHsBinds,
 660                                          pat_args = PrefixCon (map nlVarPat op_ids),
 661                                          pat_ty = pat_ty}
 662                    the_match = mkSimpleMatch [noLoc the_pat] the_rhs
 663                    the_rhs = mkHsConApp cls_data_con cls_inst_tys $
 664                              map HsVar (sc_dict_ids ++ op_ids)
 665
 666                 -- Warning: this HsCase scrutinises a value with a PredTy, which is
 667                 --          never otherwise seen in Haskell source code. It'd be
 668                 --          nicer to generate Core directly!
 669              ; return (HsCase (noLoc coerced_rep_dict) $
 670                        MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
 671         where
 672           sc_dict_ids  = map instToId sc_dicts
 673           pat_ty       = mkTyConApp cls_tycon cls_inst_tys
 674           cls_data_con = head (tyConDataCons cls_tycon)
 675           cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
 676           op_tys       = dropList sc_dict_ids cls_arg_tys
 677
 678 ------------------------
 679 -- Ordinary instances
 680
 681 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 682   = let
 683         dfun_id    = instanceDFunId ispec
 684         rigid_info = InstSkol
 685         inst_ty    = idType dfun_id
 686         loc        = getSrcSpan dfun_id
 687     in
 688          -- Prime error recovery
 689     recoverM (return emptyLHsBinds)             $
 690     setSrcSpan loc                              $
 691     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do
 692
 693         -- Instantiate the instance decl with skolem constants
 694     (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
 695                 -- These inst_tyvars' scope over the 'where' part
 696                 -- Those tyvars are inside the dfun_id's type, which is a bit
 697                 -- bizarre, but OK so long as you realise it!
 698     let
 699         (clas, inst_tys') = tcSplitDFunHead inst_head'
 700         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 701
 702         -- Instantiate the super-class context with inst_tys
 703         sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
 704         (eq_sc_theta',dict_sc_theta')     = partition isEqPred sc_theta'
 705         origin    = SigOrigin rigid_info
 706         (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
 707
 708          -- Create dictionary Ids from the specified instance contexts.
 709     sc_loc        <- getInstLoc InstScOrigin
 710     sc_dicts      <- newDictBndrs sc_loc dict_sc_theta'
 711     inst_loc      <- getInstLoc origin
 712     sc_covars     <- mkMetaCoVars eq_sc_theta'
 713     wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
 714     dfun_covars   <- mkCoVars eq_dfun_theta'
 715     dfun_eqs      <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
 716     dfun_dicts    <- newDictBndrs inst_loc dict_dfun_theta'
 717     this_dict     <- newDictBndr inst_loc (mkClassPred clas inst_tys')
 718                 -- Default-method Ids may be mentioned in synthesised RHSs,
 719                 -- but they'll already be in the environment.
 720
 721         -- Typecheck the methods
 722     let -- These insts are in scope; quite a few, eh?
 723         dfun_insts      = dfun_eqs      ++ dfun_dicts
 724         wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
 725         this_dict_id    = instToId this_dict
 726         sc_dict_ids     = map instToId sc_dicts
 727         dfun_dict_ids   = map instToId dfun_dicts
 728         prag_fn         = mkPragFun uprags
 729         tc_meth         = tcInstanceMethod loc clas inst_tyvars'
 730                                            (dfun_covars ++ dfun_dict_ids)
 731                                            dfun_theta' inst_tys'
 732                                            this_dict_id dfun_id
 733                                            prag_fn monobinds
 734     (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
 735
 736     -- Figure out bindings for the superclass context
 737     -- Don't include this_dict in the 'givens', else
 738     -- wanted_sc_insts get bound by just selecting  from this_dict!!
 739     sc_binds <- addErrCtxt superClassCtxt $
 740                 tcSimplifySuperClasses inst_loc dfun_insts
 741                                                 wanted_sc_insts
 742                 -- Note [Recursive superclasses]
 743
 744     -- It's possible that the superclass stuff might unified one
 745     -- of the inst_tyavars' with something in the envt
 746     checkSigTyVars inst_tyvars'
 747
 748     -- Deal with 'SPECIALISE instance' pragmas
 749     prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
 750
 751     -- Create the result bindings
 752     let
 753         dict_constr   = classDataCon clas
 754         inline_prag | null dfun_insts  = []
 755                     | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
 756                 -- Always inline the dfun; this is an experimental decision
 757                 -- because it makes a big performance difference sometimes.
 758                 -- Often it means we can do the method selection, and then
 759                 -- inline the method as well.  Marcin's idea; see comments below.
 760                 --
 761                 -- BUT: don't inline it if it's a constant dictionary;
 762                 -- we'll get all the benefit without inlining, and we get
 763                 -- a **lot** of code duplication if we inline it
 764                 --
 765                 --      See Note [Inline dfuns] below
 766
 767         dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
 768                                           (map HsVar sc_dict_ids ++ meth_exprs)
 769                 -- We don't produce a binding for the dict_constr; instead we
 770                 -- rely on the simplifier to unfold this saturated application
 771                 -- We do this rather than generate an HsCon directly, because
 772                 -- it means that the special cases (e.g. dictionary with only one
 773                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 774                 -- than needing to be repeated here.
 775
 776         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
 777
 778         main_bind = noLoc $ AbsBinds
 779                             (inst_tyvars' ++ dfun_covars)
 780                             dfun_dict_ids
 781                             [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
 782                             (dict_bind `consBag` sc_binds)
 783
 784     showLIE (text "instance")
 785     return (main_bind `consBag` unionManyBags meth_binds)
 786
 787 mkCoVars :: [PredType] -> TcM [TyVar]
 788 mkCoVars = newCoVars . map unEqPred
 789   where
 790     unEqPred (EqPred ty1 ty2) = (ty1, ty2)
 791     unEqPred _                = panic "TcInstDcls.mkCoVars"
 792
 793 mkMetaCoVars :: [PredType] -> TcM [TyVar]
 794 mkMetaCoVars = mapM eqPredToCoVar
 795   where
 796     eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
 797     eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
 798 \end{code}
 799
 800 Note [Recursive superclasses]
 801 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 802 See Trac #1470 for why we would *like* to add "this_dict" to the
 803 available instances here.  But we can't do so because then the superclases
 804 get satisfied by selection from this_dict, and that leads to an immediate
 805 loop.  What we need is to add this_dict to Avails without adding its
 806 superclasses, and we currently have no way to do that.
 807
 808
 809 %************************************************************************
 810 %*                                                                      *
 811       Type-checking an instance method
 812 %*                                                                      *
 813 %************************************************************************
 814
 815 tcInstanceMethod
 816 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
 817 - Remembering to use fresh Name (the instance method Name) as the binder
 818 - Bring the instance method Ids into scope, for the benefit of tcInstSig
 819 - Use sig_fn mapping instance method Name -> instance tyvars
 820 - Ditto prag_fn
 821 - Use tcValBinds to do the checking
 822
 823 \begin{code}
 824 tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
 825                  -> TcThetaType -> [TcType]
 826                  -> Id -> Id
 827                  -> TcPragFun -> LHsBinds Name
 828                  -> (Id, DefMeth)
 829                  -> TcM (HsExpr Id, LHsBinds Id)
 830         -- The returned inst_meth_ids all have types starting
 831         --      forall tvs. theta => ...
 832
 833 tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys
 834                  this_dict_id dfun_id
 835                  prag_fn binds_in (sel_id, dm_info)
 836   = do  { uniq <- newUnique
 837         ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName
 838               tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
 839                                              this_dict_id dfun_id sel_id
 840                                              prags local_meth_name
 841
 842         ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
 843                 -- There is a user-supplied method binding, so use it
 844             (Just user_bind, _) -> tc_body user_bind
 845
 846                 -- The user didn't supply a method binding, so we have to make
 847                 -- up a default binding, in a way depending on the default-method info
 848
 849             (Nothing, GenDefMeth) -> do         -- Derivable type classes stuff
 850                         { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
 851                         ; tc_body meth_bind }
 852
 853             (Nothing, NoDefMeth) -> do          -- No default method in the class
 854                         { warn <- doptM Opt_WarnMissingMethods
 855                         ; warnTc (warn  -- Warn only if -fwarn-missing-methods
 856                                   && reportIfUnused (getOccName sel_id))
 857                                         -- Don't warn about _foo methods
 858                                  omitted_meth_warn
 859                         ; return (error_rhs, emptyBag) }
 860
 861             (Nothing, DefMeth) -> do    -- An polymorphic default method
 862                         {   -- Build the typechecked version directly,
 863                             -- without calling typecheck_method;
 864                             -- see Note [Default methods in instances]
 865                           dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
 866                                         -- Might not be imported, but will be an OrigName
 867                         ; dm_id   <- tcLookupId dm_name
 868                         ; return (wrapId dm_wrapper dm_id, emptyBag) } }
 869   where
 870     sel_name = idName sel_id
 871     sel_occ  = nameOccName sel_name
 872     prags    = prag_fn sel_name
 873
 874     error_rhs    = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg
 875     meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
 876     error_id     = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
 877     error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
 878     error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 879
 880     dm_wrapper   = WpApp this_dict_id <.> mkWpTyApps inst_tys
 881
 882     omitted_meth_warn :: SDoc
 883     omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
 884                         <+> quotes (ppr sel_id)
 885
 886 ---------------
 887 tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
 888                      -> TcThetaType -> [TcType]
 889                      -> Id -> Id -> Id
 890                      -> [LSig Name] -> Name -> LHsBind Name
 891                      -> TcM (HsExpr Id, LHsBinds Id)
 892 tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
 893                      this_dict_id dfun_id sel_id
 894                      prags local_meth_name bind@(L loc _)
 895   = do  { uniq <- newUnique
 896         ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
 897               rho_ty = ASSERT( length sel_tyvars == length inst_tys )
 898                        substTyWith sel_tyvars inst_tys sel_rho
 899
 900               (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
 901                         `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
 902
 903               meth_name = mkInternalName uniq (getOccName local_meth_name) loc
 904               meth_ty = mkSigmaTy tyvars theta meth_tau
 905               meth_id = mkLocalId meth_name meth_ty
 906
 907               local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
 908               local_meth_id = mkLocalId local_meth_name local_meth_ty
 909
 910               tv_names = map tyVarName tyvars
 911
 912                       -- The first predicate should be of form (C a b)
 913                       -- where C is the class in question
 914         ; MASSERT( case getClassPredTys_maybe first_pred of
 915                         { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
 916
 917         ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind
 918
 919         ; let full_bind = unitBag $ L loc $
 920                           VarBind meth_id $ L loc $
 921                           mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
 922                           HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $
 923                           mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
 924                           wrapId meth_wrapper local_meth_id
 925               this_dict_bind = unitBag $ L loc $
 926                                VarBind this_dict_id $ L loc $
 927                                wrapId meth_wrapper dfun_id
 928
 929         ; return (wrapId meth_wrapper meth_id, full_bind) }
 930   where
 931     meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
 932
 933 wrapId :: HsWrapper -> id -> HsExpr id
 934 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
 935 \end{code}
 936
 937 Note [Default methods in instances]
 938 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 939 Consider this
 940
 941    class Baz v x where
 942       foo :: x -> x
 943       foo y = y
 944
 945    instance Baz Int Int
 946
 947 From the class decl we get
 948
 949    $dmfoo :: forall v x. Baz v x => x -> x
 950
 951 Notice that the type is ambiguous.  That's fine, though. The instance decl generates
 952
 953    $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
 954
 955 BUT this does mean we must generate the dictionary translation directly, rather
 956 than generating source-code and type-checking it.  That was the bug ing
 957 Trac #1061. In any case it's less work to generate the translated version!
 958
 959
 960 %************************************************************************
 961 %*                                                                      *
 962 \subsection{Error messages}
 963 %*                                                                      *
 964 %************************************************************************
 965
 966 \begin{code}
 967 instDeclCtxt1 :: LHsType Name -> SDoc
 968 instDeclCtxt1 hs_inst_ty
 969   = inst_decl_ctxt (case unLoc hs_inst_ty of
 970                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
 971                         HsPredTy pred                    -> ppr pred
 972                         _                                -> ppr hs_inst_ty)     -- Don't expect this
 973 instDeclCtxt2 :: Type -> SDoc
 974 instDeclCtxt2 dfun_ty
 975   = inst_decl_ctxt (ppr (mkClassPred cls tys))
 976   where
 977     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 978
 979 inst_decl_ctxt :: SDoc -> SDoc
 980 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
 981
 982 superClassCtxt :: SDoc
 983 superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
 984
 985 atInstCtxt :: Name -> SDoc
 986 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
 987                   quotes (ppr name)
 988
 989 mustBeVarArgErr :: Type -> SDoc
 990 mustBeVarArgErr ty =
 991   sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
 992         ptext (sLit "must be variables")
 993       , ptext (sLit "Instead of a variable, found") <+> ppr ty
 994       ]
 995
 996 wrongATArgErr :: Type -> Type -> SDoc
 997 wrongATArgErr ty instTy =
 998   sep [ ptext (sLit "Type indexes must match class instance head")
 999       , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>
1000          ppr instTy
1001       ]
1002 \end{code}