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