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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
  17
  18 #include "HsVersions.h"
  19
  20 import HsSyn
  21 import TcBinds
  22 import TcTyClsDecls
  23 import TcClassDcl
  24 import TcRnMonad
  25 import TcMType
  26 import TcType
  27 import Inst
  28 import InstEnv
  29 import FamInst
  30 import FamInstEnv
  31 import TcDeriv
  32 import TcEnv
  33 import TcHsType
  34 import TcUnify
  35 import TcSimplify
  36 import Type
  37 import Coercion
  38 import TyCon
  39 import TypeRep
  40 import DataCon
  41 import Class
  42 import Var
  43 import MkId
  44 import Name
  45 import NameSet
  46 import DynFlags
  47 import SrcLoc
  48 import ListSetOps
  49 import Util
  50 import Outputable
  51 import Bag
  52 import BasicTypes
  53 import HscTypes
  54 import FastString
  55
  56 import Data.Maybe
  57 import Control.Monad
  58 import Data.List
  59 \end{code}
  60
  61 Typechecking instance declarations is done in two passes. The first
  62 pass, made by @tcInstDecls1@, collects information to be used in the
  63 second pass.
  64
  65 This pre-processed info includes the as-yet-unprocessed bindings
  66 inside the instance declaration.  These are type-checked in the second
  67 pass, when the class-instance envs and GVE contain all the info from
  68 all the instance and value decls.  Indeed that's the reason we need
  69 two passes over the instance decls.
  70
  71 Here is the overall algorithm.
  72 Assume that we have an instance declaration
  73
  74     instance c => k (t tvs) where b
  75
  76 \begin{enumerate}
  77 \item
  78 $LIE_c$ is the LIE for the context of class $c$
  79 \item
  80 $betas_bar$ is the free variables in the class method type, excluding the
  81    class variable
  82 \item
  83 $LIE_cop$ is the LIE constraining a particular class method
  84 \item
  85 $tau_cop$ is the tau type of a class method
  86 \item
  87 $LIE_i$ is the LIE for the context of instance $i$
  88 \item
  89 $X$ is the instance constructor tycon
  90 \item
  91 $gammas_bar$ is the set of type variables of the instance
  92 \item
  93 $LIE_iop$ is the LIE for a particular class method instance
  94 \item
  95 $tau_iop$ is the tau type for this instance of a class method
  96 \item
  97 $alpha$ is the class variable
  98 \item
  99 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 100 \item
 101 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 102 \end{enumerate}
 103
 104 ToDo: Update the list above with names actually in the code.
 105
 106 \begin{enumerate}
 107 \item
 108 First, make the LIEs for the class and instance contexts, which means
 109 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 110 and make LIElistI and LIEI.
 111 \item
 112 Then process each method in turn.
 113 \item
 114 order the instance methods according to the ordering of the class methods
 115 \item
 116 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 117 \item
 118 Create final dictionary function from bindings generated already
 119 \begin{pseudocode}
 120 df = lambda inst_tyvars
 121        lambda LIEI
 122          let Bop1
 123              Bop2
 124              ...
 125              Bopn
 126          and dbinds_super
 127               in <op1,op2,...,opn,sd1,...,sdm>
 128 \end{pseudocode}
 129 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 130 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 131 \end{enumerate}
 132
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{Extracting instance decls}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 Gather up the instance declarations from their various sources
 141
 142 \begin{code}
 143 tcInstDecls1    -- Deal with both source-code and imported instance decls
 144    :: [LTyClDecl Name]          -- For deriving stuff
 145    -> [LInstDecl Name]          -- Source code instance decls
 146    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
 147    -> TcM (TcGblEnv,            -- The full inst env
 148            [InstInfo],          -- Source-code instance decls to process;
 149                                 -- contains all dfuns for this module
 150            HsValBinds Name)     -- Supporting bindings for derived instances
 151
 152 tcInstDecls1 tycl_decls inst_decls deriv_decls
 153   = checkNoErrs $
 154     do {        -- Stop if addInstInfos etc discovers any errors
 155                 -- (they recover, so that we get more than one error each
 156                 -- round)
 157
 158                 -- (1) Do class and family instance declarations
 159        ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
 160        ; local_info_tycons <- mapM tcLocalInstDecl1  inst_decls
 161        ; idx_tycons        <- mapM tcIdxTyInstDeclTL idxty_decls
 162
 163        ; let { (local_infos,
 164                 at_tycons)     = unzip local_info_tycons
 165              ; local_info      = concat local_infos
 166              ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
 167              ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
 168              ; implicit_things = concatMap implicitTyThings at_idx_tycon
 169              }
 170
 171                 -- (2) Add the tycons of indexed types and their implicit
 172                 --     tythings to the global environment
 173        ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
 174
 175                 -- (3) Instances from generic class declarations
 176        ; generic_inst_info <- getGenericInstances clas_decls
 177
 178                 -- Next, construct the instance environment so far, consisting
 179                 -- of
 180                 --   a) local instance decls
 181                 --   b) generic instances
 182                 --   c) local family instance decls
 183        ; addInsts local_info         $ do {
 184        ; addInsts generic_inst_info  $ do {
 185        ; addFamInsts at_idx_tycon    $ do {
 186
 187                 -- (4) Compute instances from "deriving" clauses;
 188                 -- This stuff computes a context for the derived instance
 189                 -- decl, so it needs to know about all the instances possible
 190                 -- NB: class instance declarations can contain derivings as
 191                 --     part of associated data type declarations
 192        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
 193                                                       deriv_decls
 194        ; addInsts deriv_inst_info   $ do {
 195
 196        ; gbl_env <- getGblEnv
 197        ; return (gbl_env,
 198                   generic_inst_info ++ deriv_inst_info ++ local_info,
 199                   deriv_binds)
 200     }}}}}}
 201   where
 202     -- Make sure that toplevel type instance are not for associated types.
 203     -- !!!TODO: Need to perform this check for the TyThing of type functions,
 204     --          too.
 205     tcIdxTyInstDeclTL ldecl@(L loc decl) =
 206       do { tything <- tcFamInstDecl ldecl
 207          ; setSrcSpan loc $
 208              when (isAssocFamily tything) $
 209                addErr $ assocInClassErr (tcdName decl)
 210          ; return tything
 211          }
 212     isAssocFamily (Just (ATyCon tycon)) =
 213       case tyConFamInst_maybe tycon of
 214         Nothing       -> panic "isAssocFamily: no family?!?"
 215         Just (fam, _) -> isTyConAssoc fam
 216     isAssocFamily (Just _             ) = panic "isAssocFamily: no tycon?!?"
 217     isAssocFamily Nothing               = False
 218
 219 assocInClassErr name =
 220   ptext SLIT("Associated type") <+> quotes (ppr name) <+>
 221   ptext SLIT("must be inside a class instance")
 222
 223 addInsts :: [InstInfo] -> TcM a -> TcM a
 224 addInsts infos thing_inside
 225   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 226
 227 addFamInsts :: [TyThing] -> TcM a -> TcM a
 228 addFamInsts tycons thing_inside
 229   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
 230   where
 231     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
 232     mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
 233                                                     (ppr tything)
 234 \end{code}
 235
 236 \begin{code}
 237 tcLocalInstDecl1 :: LInstDecl Name
 238                  -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
 239         -- A source-file instance declaration
 240         -- Type-check all the stuff before the "where"
 241         --
 242         -- We check for respectable instance type, and context
 243 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 244   =     -- Prime error recovery, set source location
 245     recoverM (return ([], []))          $
 246     setSrcSpan loc                      $
 247     addErrCtxt (instDeclCtxt1 poly_ty)  $
 248
 249     do  { is_boot <- tcIsHsBoot
 250         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
 251                   badBootDeclErr
 252
 253         ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 254
 255         -- Next, process any associated types.
 256         ; idx_tycons <- mapM tcFamInstDecl ats
 257
 258         -- Now, check the validity of the instance.
 259         ; (clas, inst_tys) <- checkValidInstHead tau
 260         ; checkValidInstance tyvars theta clas inst_tys
 261         ; checkValidAndMissingATs clas (tyvars, inst_tys)
 262                                   (zip ats idx_tycons)
 263
 264         -- Finally, construct the Core representation of the instance.
 265         -- (This no longer includes the associated types.)
 266         ; dfun_name <- newDFunName clas inst_tys loc
 267         ; overlap_flag <- getOverlapFlag
 268         ; let (eq_theta,dict_theta) = partition isEqPred theta
 269               theta'         = eq_theta ++ dict_theta
 270               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
 271               ispec          = mkLocalInstance dfun overlap_flag
 272
 273         ; return ([InstInfo { iSpec  = ispec,
 274                               iBinds = VanillaInst binds uprags }],
 275                   catMaybes idx_tycons)
 276         }
 277   where
 278     -- We pass in the source form and the type checked form of the ATs.  We
 279     -- really need the source form only to be able to produce more informative
 280     -- error messages.
 281     checkValidAndMissingATs :: Class
 282                             -> ([TyVar], [TcType])     -- instance types
 283                             -> [(LTyClDecl Name,       -- source form of AT
 284                                  Maybe TyThing)]       -- Core form of AT
 285                             -> TcM ()
 286     checkValidAndMissingATs clas inst_tys ats
 287       = do { -- Issue a warning for each class AT that is not defined in this
 288              -- instance.
 289            ; let class_ats   = map tyConName (classATs clas)
 290                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
 291                  omitted     = filterOut (`elemNameSet` defined_ats) class_ats
 292            ; warn <- doptM Opt_WarnMissingMethods
 293            ; mapM_ (warnTc warn . omittedATWarn) omitted
 294
 295              -- Ensure that all AT indexes that correspond to class parameters
 296              -- coincide with the types in the instance head.  All remaining
 297              -- AT arguments must be variables.  Also raise an error for any
 298              -- type instances that are not associated with this class.
 299            ; mapM_ (checkIndexes clas inst_tys) ats
 300            }
 301
 302     checkIndexes _    _        (hsAT, Nothing)             =
 303       return ()    -- skip, we already had an error here
 304     checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
 305 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
 306       checkIndexes' clas inst_tys hsAT
 307                     (tyConTyVars tycon,
 308                      snd . fromJust . tyConFamInst_maybe $ tycon)
 309     checkIndexes _ _ _ = panic "checkIndexes"
 310
 311     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
 312       = let atName = tcdName . unLoc $ hsAT
 313         in
 314         setSrcSpan (getLoc hsAT)       $
 315         addErrCtxt (atInstCtxt atName) $
 316         case find ((atName ==) . tyConName) (classATs clas) of
 317           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
 318           Just atDecl ->
 319             case assocTyConArgPoss_maybe atDecl of
 320               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
 321               Just poss ->
 322
 323                 -- The following is tricky!  We need to deal with three
 324                 -- complications: (1) The AT possibly only uses a subset of
 325                 -- the class parameters as indexes and those it uses may be in
 326                 -- a different order; (2) the AT may have extra arguments,
 327                 -- which must be type variables; and (3) variables in AT and
 328                 -- instance head will be different `Name's even if their
 329                 -- source lexemes are identical.
 330                 --
 331                 -- Re (1), `poss' contains a permutation vector to extract the
 332                 -- class parameters in the right order.
 333                 --
 334                 -- Re (2), we wrap the (permuted) class parameters in a Maybe
 335                 -- type and use Nothing for any extra AT arguments.  (First
 336                 -- equation of `checkIndex' below.)
 337                 --
 338                 -- Re (3), we replace any type variable in the AT parameters
 339                 -- that has the same source lexeme as some variable in the
 340                 -- instance types with the instance type variable sharing its
 341                 -- source lexeme.
 342                 --
 343                 let relevantInstTys = map (instTys !!) poss
 344                     instArgs        = map Just relevantInstTys ++
 345                                       repeat Nothing  -- extra arguments
 346                     renaming        = substSameTyVar atTvs instTvs
 347                 in
 348                 zipWithM_ checkIndex (substTys renaming atTys) instArgs
 349
 350     checkIndex ty Nothing
 351       | isTyVarTy ty         = return ()
 352       | otherwise            = addErrTc $ mustBeVarArgErr ty
 353     checkIndex ty (Just instTy)
 354       | ty `tcEqType` instTy = return ()
 355       | otherwise            = addErrTc $ wrongATArgErr ty instTy
 356
 357     listToNameSet = addListToNameSet emptyNameSet
 358
 359     substSameTyVar []       _            = emptyTvSubst
 360     substSameTyVar (tv:tvs) replacingTvs =
 361       let replacement = case find (tv `sameLexeme`) replacingTvs of
 362                           Nothing  -> mkTyVarTy tv
 363                           Just rtv -> mkTyVarTy rtv
 364           --
 365           tv1 `sameLexeme` tv2 =
 366             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
 367       in
 368       extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
 369 \end{code}
 370
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsection{Type-checking instance declarations, pass 2}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 \begin{code}
 379 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
 380              -> TcM (LHsBinds Id, TcLclEnv)
 381 -- (a) From each class declaration,
 382 --      generate any default-method bindings
 383 -- (b) From each instance decl
 384 --      generate the dfun binding
 385
 386 tcInstDecls2 tycl_decls inst_decls
 387   = do  {       -- (a) Default methods from class decls
 388           (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
 389                                     filter (isClassDecl.unLoc) tycl_decls
 390         ; tcExtendIdEnv (concat dm_ids_s)       $ do
 391
 392                 -- (b) instance declarations
 393         ; inst_binds_s <- mapM tcInstDecl2 inst_decls
 394
 395                 -- Done
 396         ; let binds = unionManyBags dm_binds_s `unionBags`
 397                       unionManyBags inst_binds_s
 398         ; tcl_env <- getLclEnv          -- Default method Ids in here
 399         ; return (binds, tcl_env) }
 400 \end{code}
 401
 402 ======= New documentation starts here (Sept 92)  ==============
 403
 404 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 405 the dictionary function for this instance declaration.  For example
 406
 407         instance Foo a => Foo [a] where
 408                 op1 x = ...
 409                 op2 y = ...
 410
 411 might generate something like
 412
 413         dfun.Foo.List dFoo_a = let op1 x = ...
 414                                    op2 y = ...
 415                                in
 416                                    Dict [op1, op2]
 417
 418 HOWEVER, if the instance decl has no context, then it returns a
 419 bigger @HsBinds@ with declarations for each method.  For example
 420
 421         instance Foo [a] where
 422                 op1 x = ...
 423                 op2 y = ...
 424
 425 might produce
 426
 427         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 428         const.Foo.op1.List a x = ...
 429         const.Foo.op2.List a y = ...
 430
 431 This group may be mutually recursive, because (for example) there may
 432 be no method supplied for op2 in which case we'll get
 433
 434         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 435
 436 that is, the default method applied to the dictionary at this type.
 437 What we actually produce in either case is:
 438
 439         AbsBinds [a] [dfun_theta_dicts]
 440                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 441                  { d = (sd1,sd2, ..., op1, op2, ...)
 442                    op1 = ...
 443                    op2 = ...
 444                  }
 445
 446 The "maybe" says that we only ask AbsBinds to make global constant methods
 447 if the dfun_theta is empty.
 448
 449 For an instance declaration, say,
 450
 451         instance (C1 a, C2 b) => C (T a b) where
 452                 ...
 453
 454 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 455 function whose type is
 456
 457         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 458
 459 Notice that we pass it the superclass dictionaries at the instance type; this
 460 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 461 is the @dfun_theta@ below.
 462
 463
 464 \begin{code}
 465 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 466 -- Returns a binding for the dfun
 467
 468 ------------------------
 469 -- Derived newtype instances; surprisingly tricky!
 470 --
 471 --      class Show a => Foo a b where ...
 472 --      newtype N a = MkN (Tree [a]) deriving( Foo Int )
 473 --
 474 -- The newtype gives an FC axiom looking like
 475 --      axiom CoN a ::  N a :=: Tree [a]
 476 --   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
 477 --
 478 -- So all need is to generate a binding looking like:
 479 --      dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
 480 --      dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
 481 --                case df `cast` (Foo Int (sym (CoN a))) of
 482 --                   Foo _ op1 .. opn -> Foo ds op1 .. opn
 483 --
 484 -- If there are no superclasses, matters are simpler, because we don't need the case
 485 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
 486
 487 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
 488   = do  { let dfun_id      = instanceDFunId ispec
 489               rigid_info   = InstSkol
 490               origin       = SigOrigin rigid_info
 491               inst_ty      = idType dfun_id
 492         ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
 493                 -- inst_head_ty is a PredType
 494
 495         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
 496               (class_tyvars, sc_theta, _, op_items) = classBigSig cls
 497               cls_tycon = classTyCon cls
 498               sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
 499
 500               Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
 501               (nt_tycon, tc_args) = tcSplitTyConApp last_ty     -- Can't fail
 502               rep_ty              = newTyConInstRhs nt_tycon tc_args
 503
 504               rep_pred     = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
 505                                 -- In our example, rep_pred is (Foo Int (Tree [a]))
 506               the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 507                                 -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
 508
 509         ; inst_loc   <- getInstLoc origin
 510         ; sc_loc     <- getInstLoc InstScOrigin
 511         ; dfun_dicts <- newDictBndrs inst_loc theta
 512         ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
 513         ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
 514         ; rep_dict   <- newDictBndr inst_loc rep_pred
 515
 516         -- Figure out bindings for the superclass context from dfun_dicts
 517         -- Don't include this_dict in the 'givens', else
 518         -- wanted_sc_insts get bound by just selecting from this_dict!!
 519         ; sc_binds <- addErrCtxt superClassCtxt $
 520                       tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
 521
 522         ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
 523
 524         ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 525         ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 526
 527         ; return (unitBag $ noLoc $
 528                   AbsBinds  tvs (map instToVar dfun_dicts)
 529                             [(tvs, dfun_id, instToId this_dict, [])]
 530                             (dict_bind `consBag` sc_binds)) }
 531   where
 532       -----------------------
 533       --        make_coercion
 534       -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
 535       -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
 536       --        with kind (C s1 .. sm (T a1 .. ak)  :=:  C s1 .. sm <rep_ty>)
 537       --        where rep_ty is the (eta-reduced) type rep of T
 538       -- So we just replace T with CoT, and insert a 'sym'
 539       -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
 540
 541     make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 542         | Just co_con <- newTyConCo_maybe nt_tycon
 543         , let co = mkSymCoercion (mkTyConApp co_con tc_args)
 544         = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
 545         | otherwise     -- The newtype is transparent; no need for a cast
 546         = idHsWrapper
 547
 548       -----------------------
 549       --     (make_body C tys scs coreced_rep_dict)
 550       --                returns
 551       --     (case coerced_rep_dict of { C _ ops -> C scs ops })
 552       -- But if there are no superclasses, it returns just coerced_rep_dict
 553       -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
 554
 555     make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 556         | null sc_dicts         -- Case (a)
 557         = return coerced_rep_dict
 558         | otherwise             -- Case (b)
 559         = do { op_ids            <- newSysLocalIds FSLIT("op") op_tys
 560              ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
 561              ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
 562                                          pat_dicts = dummy_sc_dict_ids,
 563                                          pat_binds = emptyLHsBinds,
 564                                          pat_args = PrefixCon (map nlVarPat op_ids),
 565                                          pat_ty = pat_ty}
 566                    the_match = mkSimpleMatch [noLoc the_pat] the_rhs
 567                    the_rhs = mkHsConApp cls_data_con cls_inst_tys $
 568                              map HsVar (sc_dict_ids ++ op_ids)
 569
 570                 -- Warning: this HsCase scrutinises a value with a PredTy, which is
 571                 --          never otherwise seen in Haskell source code. It'd be
 572                 --          nicer to generate Core directly!
 573              ; return (HsCase (noLoc coerced_rep_dict) $
 574                        MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
 575         where
 576           sc_dict_ids  = map instToId sc_dicts
 577           pat_ty       = mkTyConApp cls_tycon cls_inst_tys
 578           cls_data_con = head (tyConDataCons cls_tycon)
 579           cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
 580           op_tys       = dropList sc_dict_ids cls_arg_tys
 581
 582 ------------------------
 583 -- Ordinary instances
 584
 585 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 586   = let
 587         dfun_id    = instanceDFunId ispec
 588         rigid_info = InstSkol
 589         inst_ty    = idType dfun_id
 590         loc        = srcLocSpan (getSrcLoc dfun_id)
 591     in
 592          -- Prime error recovery
 593     recoverM (return emptyLHsBinds)             $
 594     setSrcSpan loc                              $
 595     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do
 596
 597         -- Instantiate the instance decl with skolem constants
 598     (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
 599                 -- These inst_tyvars' scope over the 'where' part
 600                 -- Those tyvars are inside the dfun_id's type, which is a bit
 601                 -- bizarre, but OK so long as you realise it!
 602     let
 603         (clas, inst_tys') = tcSplitDFunHead inst_head'
 604         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 605
 606         -- Instantiate the super-class context with inst_tys
 607         sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
 608         (eq_sc_theta',dict_sc_theta')     = partition isEqPred sc_theta'
 609         origin    = SigOrigin rigid_info
 610         (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
 611
 612          -- Create dictionary Ids from the specified instance contexts.
 613     sc_loc        <- getInstLoc InstScOrigin
 614     sc_dicts      <- newDictBndrs sc_loc dict_sc_theta'
 615     inst_loc      <- getInstLoc origin
 616     sc_covars     <- mkMetaCoVars eq_sc_theta'
 617     wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
 618     dfun_covars   <- mkCoVars eq_dfun_theta'
 619     dfun_eqs      <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
 620     dfun_dicts    <- newDictBndrs inst_loc dict_dfun_theta'
 621     this_dict     <- newDictBndr inst_loc (mkClassPred clas inst_tys')
 622                 -- Default-method Ids may be mentioned in synthesised RHSs,
 623                 -- but they'll already be in the environment.
 624
 625         -- Typecheck the methods
 626     let         -- These insts are in scope; quite a few, eh?
 627         dfun_insts      = dfun_eqs ++ dfun_dicts
 628         wanted_sc_insts = wanted_sc_eqs   ++ sc_dicts
 629         given_sc_eqs    = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
 630         given_sc_insts  = given_sc_eqs   ++ sc_dicts
 631         avail_insts     = [this_dict] ++ dfun_insts ++ given_sc_insts
 632
 633     (meth_ids, meth_binds) <- tcMethods origin clas inst_tyvars'
 634                                  dfun_theta' inst_tys' avail_insts
 635                                  op_items monobinds uprags
 636
 637         -- Figure out bindings for the superclass context
 638         -- Don't include this_dict in the 'givens', else
 639         -- wanted_sc_insts get bound by just selecting  from this_dict!!
 640     sc_binds <- addErrCtxt superClassCtxt
 641                    (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts)
 642
 643         -- It's possible that the superclass stuff might unified one
 644         -- of the inst_tyavars' with something in the envt
 645     checkSigTyVars inst_tyvars'
 646
 647         -- Deal with 'SPECIALISE instance' pragmas
 648     prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
 649
 650         -- Create the result bindings
 651     let
 652         dict_constr   = classDataCon clas
 653         scs_and_meths = map instToId sc_dicts ++ meth_ids
 654         this_dict_id  = instToId this_dict
 655         inline_prag | null dfun_insts  = []
 656                     | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
 657                 -- Always inline the dfun; this is an experimental decision
 658                 -- because it makes a big performance difference sometimes.
 659                 -- Often it means we can do the method selection, and then
 660                 -- inline the method as well.  Marcin's idea; see comments below.
 661                 --
 662                 -- BUT: don't inline it if it's a constant dictionary;
 663                 -- we'll get all the benefit without inlining, and we get
 664                 -- a **lot** of code duplication if we inline it
 665                 --
 666                 --      See Note [Inline dfuns] below
 667
 668         dict_rhs
 669           = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)  (map HsVar scs_and_meths)
 670                 -- We don't produce a binding for the dict_constr; instead we
 671                 -- rely on the simplifier to unfold this saturated application
 672                 -- We do this rather than generate an HsCon directly, because
 673                 -- it means that the special cases (e.g. dictionary with only one
 674                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 675                 -- than needing to be repeated here.
 676
 677         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
 678         all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
 679
 680         main_bind = noLoc $ AbsBinds
 681                             (inst_tyvars' ++ dfun_covars)
 682                             (map instToId dfun_dicts)
 683                             [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
 684                             all_binds
 685
 686     showLIE (text "instance")
 687     return (unitBag main_bind)
 688
 689 mkCoVars :: [PredType] -> TcM [TyVar]
 690 mkCoVars = newCoVars . map unEqPred
 691   where
 692     unEqPred (EqPred ty1 ty2) = (ty1, ty2)
 693     unEqPred _                = panic "TcInstDcls.mkCoVars"
 694
 695 mkMetaCoVars :: [PredType] -> TcM [TyVar]
 696 mkMetaCoVars = mapM eqPredToCoVar
 697   where
 698     eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
 699     eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
 700
 701 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
 702           avail_insts op_items monobinds uprags = do
 703         -- Check that all the method bindings come from this class
 704     let
 705         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 706         bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
 707
 708     mapM (addErrTc . badMethodErr clas) bad_bndrs
 709
 710         -- Make the method bindings
 711     let
 712         mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
 713
 714     (meth_insts, meth_infos) <- mapAndUnzipM mk_method_bind op_items
 715
 716         -- And type check them
 717         -- It's really worth making meth_insts available to the tcMethodBind
 718         -- Consider     instance Monad (ST s) where
 719         --                {-# INLINE (>>) #-}
 720         --                (>>) = ...(>>=)...
 721         -- If we don't include meth_insts, we end up with bindings like this:
 722         --      rec { dict = MkD then bind ...
 723         --            then = inline_me (... (GHC.Base.>>= dict) ...)
 724         --            bind = ... }
 725         -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
 726         -- and (b) the inline_me prevents us inlining the >>= selector, which
 727         -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
 728         -- is not inlined across modules. Rather ironic since this does not
 729         -- happen without the INLINE pragma!
 730         --
 731         -- Solution: make meth_insts available, so that 'then' refers directly
 732         --           to the local 'bind' rather than going via the dictionary.
 733         --
 734         -- BUT WATCH OUT!  If the method type mentions the class variable, then
 735         -- this optimisation is not right.  Consider
 736         --      class C a where
 737         --        op :: Eq a => a
 738         --
 739         --      instance C Int where
 740         --        op = op
 741         -- The occurrence of 'op' on the rhs gives rise to a constraint
 742         --      op at Int
 743         -- The trouble is that the 'meth_inst' for op, which is 'available', also
 744         -- looks like 'op at Int'.  But they are not the same.
 745     let
 746         prag_fn        = mkPragFun uprags
 747         all_insts      = avail_insts ++ catMaybes meth_insts
 748         sig_fn n       = Just []        -- No scoped type variables, but every method has
 749                                         -- a type signature, in effect, so that we check
 750                                         -- the method has the right type
 751         tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
 752         meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
 753
 754     meth_binds_s <- mapM tc_method_bind meth_infos
 755
 756     return (meth_ids, unionManyBags meth_binds_s)
 757 \end{code}
 758
 759
 760                 ------------------------------
 761         [Inline dfuns] Inlining dfuns unconditionally
 762                 ------------------------------
 763
 764 The code above unconditionally inlines dict funs.  Here's why.
 765 Consider this program:
 766
 767     test :: Int -> Int -> Bool
 768     test x y = (x,y) == (y,x) || test y x
 769     -- Recursive to avoid making it inline.
 770
 771 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 772 the code we end up with is good:
 773
 774     Test.$wtest =
 775         \r -> case ==# [ww ww1] of wild {
 776                 PrelBase.False -> Test.$wtest ww1 ww;
 777                 PrelBase.True ->
 778                   case ==# [ww1 ww] of wild1 {
 779                     PrelBase.False -> Test.$wtest ww1 ww;
 780                     PrelBase.True -> PrelBase.True [];
 781                   };
 782             };
 783     Test.test = \r [w w1]
 784             case w of w2 {
 785               PrelBase.I# ww ->
 786                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 787             };
 788
 789 If we don't inline the dfun, the code is not nearly as good:
 790
 791     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 792               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 793             };
 794
 795     Test.$wtest =
 796         \r [ww ww1]
 797             let { y = PrelBase.I#! [ww1]; } in
 798             let { x = PrelBase.I#! [ww]; } in
 799             let { sat_slx = PrelTup.(,)! [y x]; } in
 800             let { sat_sly = PrelTup.(,)! [x y];
 801             } in
 802               case == sat_sly sat_slx of wild {
 803                 PrelBase.False -> Test.$wtest ww1 ww;
 804                 PrelBase.True -> PrelBase.True [];
 805               };
 806
 807     Test.test =
 808         \r [w w1]
 809             case w of w2 {
 810               PrelBase.I# ww ->
 811                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 812             };
 813
 814 Why doesn't GHC inline $fEq?  Because it looks big:
 815
 816     PrelTup.zdfEqZ1T{-rcX-}
 817         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 818             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 819             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 820             let {
 821               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 822               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 823             let {
 824               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 825               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 826             let {
 827               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 828               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 829                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 830                              case ds{-rf5-}
 831                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 832                              case ds1{-rf4-}
 833                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 834                              PrelBase.zaza{-r4e-}
 835                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 836                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 837                              }
 838                              } } in
 839             let {
 840               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 841               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 842                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 843                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 844             } in
 845               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 846
 847 and it's not as bad as it seems, because it's further dramatically
 848 simplified: only zeze2 is extracted and its body is simplified.
 849
 850
 851 %************************************************************************
 852 %*                                                                      *
 853 \subsection{Error messages}
 854 %*                                                                      *
 855 %************************************************************************
 856
 857 \begin{code}
 858 instDeclCtxt1 hs_inst_ty
 859   = inst_decl_ctxt (case unLoc hs_inst_ty of
 860                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
 861                         HsPredTy pred                    -> ppr pred
 862                         other                            -> ppr hs_inst_ty)     -- Don't expect this
 863 instDeclCtxt2 dfun_ty
 864   = inst_decl_ctxt (ppr (mkClassPred cls tys))
 865   where
 866     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 867
 868 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
 869
 870 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 871
 872 atInstCtxt name = ptext SLIT("In the associated type instance for") <+>
 873                   quotes (ppr name)
 874
 875 mustBeVarArgErr ty =
 876   sep [ ptext SLIT("Arguments that do not correspond to a class parameter") <+>
 877         ptext SLIT("must be variables")
 878       , ptext SLIT("Instead of a variable, found") <+> ppr ty
 879       ]
 880
 881 wrongATArgErr ty instTy =
 882   sep [ ptext SLIT("Type indexes must match class instance head")
 883       , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>
 884          ppr instTy
 885       ]
 886 \end{code}