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