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