ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
   8
   9 #include "HsVersions.h"
  10
  11
  12 import CmdLineOpts      ( DynFlag(..), dopt )
  13
  14 import HsSyn            ( HsDecl(..), InstDecl(..), TyClDecl(..),
  15                           MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..),
  16                           andMonoBindList, collectMonoBinders, isClassDecl
  17                         )
  18 import RnHsSyn          ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
  19                           RenamedTyClDecl, RenamedHsType,
  20                           extractHsTyVars, maybeGenericMatch
  21                         )
  22 import TcHsSyn          ( TcMonoBinds, mkHsConApp )
  23 import TcBinds          ( tcSpecSigs )
  24 import TcClassDcl       ( tcMethodBind, badMethodErr )
  25 import TcMonad
  26 import Inst             ( InstOrigin(..),
  27                           newDicts, newClassDicts,
  28                           LIE, emptyLIE, plusLIE, plusLIEs )
  29 import TcDeriv          ( tcDeriving )
  30 import TcEnv            ( TcEnv, tcExtendGlobalValEnv,
  31                           tcExtendTyVarEnvForMeths,
  32                           tcAddImportedIdInfo, tcInstId, tcLookupClass,
  33                           InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
  34                           newDFunName, tcExtendTyVarEnv
  35                         )
  36 import InstEnv          ( InstEnv, classDataCon, extendInstEnv )
  37 import TcMonoType       ( tcTyVars, tcHsSigType, kcHsSigType )
  38 import TcSimplify       ( tcSimplifyAndCheck )
  39 import TcType           ( zonkTcSigTyVars )
  40 import HscTypes         ( HomeSymbolTable, DFunId,
  41                           ModDetails(..), PackageInstEnv, PersistentRenamerState
  42                         )
  43
  44 import Bag              ( unionManyBags )
  45 import Class            ( Class, DefMeth(..), classBigSig )
  46 import Var              ( idName, idType )
  47 import Maybes           ( maybeToBool )
  48 import MkId             ( mkDictFunId )
  49 import Generics         ( validGenericInstanceType )
  50 import Module           ( Module, foldModuleEnv )
  51 import Name             ( getSrcLoc )
  52 import NameSet          ( emptyNameSet, nameSetToList )
  53 import PrelInfo         ( eRROR_ID )
  54 import PprType          ( pprConstraint, pprPred )
  55 import TyCon            ( TyCon, isSynTyCon, tyConDerivings )
  56 import Type             ( splitDFunTy, isTyVarTy,
  57                           splitTyConApp_maybe, splitDictTy,
  58                           splitAlgTyConApp_maybe, splitForAllTys,
  59                           unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
  60                           getClassTys_maybe
  61                         )
  62 import Subst            ( mkTopTyVarSubst, substClasses )
  63 import VarSet           ( mkVarSet, varSetElems )
  64 import TysWiredIn       ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
  65 import PrelNames        ( cCallableClassKey, cReturnableClassKey, hasKey )
  66 import Name             ( Name )
  67 import SrcLoc           ( SrcLoc )
  68 import VarSet           ( varSetElems )
  69 import Unique           ( Uniquable(..) )
  70 import BasicTypes       ( NewOrData(..), Fixity )
  71 import ErrUtils         ( dumpIfSet_dyn )
  72 import ListSetOps       ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
  73                           assocElts, extendAssoc_C,
  74                           equivClassesByUniq, minusList
  75                         )
  76 import List             ( partition )
  77 import Outputable
  78 \end{code}
  79
  80 Typechecking instance declarations is done in two passes. The first
  81 pass, made by @tcInstDecls1@, collects information to be used in the
  82 second pass.
  83
  84 This pre-processed info includes the as-yet-unprocessed bindings
  85 inside the instance declaration.  These are type-checked in the second
  86 pass, when the class-instance envs and GVE contain all the info from
  87 all the instance and value decls.  Indeed that's the reason we need
  88 two passes over the instance decls.
  89
  90
  91 Here is the overall algorithm.
  92 Assume that we have an instance declaration
  93
  94     instance c => k (t tvs) where b
  95
  96 \begin{enumerate}
  97 \item
  98 $LIE_c$ is the LIE for the context of class $c$
  99 \item
 100 $betas_bar$ is the free variables in the class method type, excluding the
 101    class variable
 102 \item
 103 $LIE_cop$ is the LIE constraining a particular class method
 104 \item
 105 $tau_cop$ is the tau type of a class method
 106 \item
 107 $LIE_i$ is the LIE for the context of instance $i$
 108 \item
 109 $X$ is the instance constructor tycon
 110 \item
 111 $gammas_bar$ is the set of type variables of the instance
 112 \item
 113 $LIE_iop$ is the LIE for a particular class method instance
 114 \item
 115 $tau_iop$ is the tau type for this instance of a class method
 116 \item
 117 $alpha$ is the class variable
 118 \item
 119 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 120 \item
 121 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 122 \end{enumerate}
 123
 124 ToDo: Update the list above with names actually in the code.
 125
 126 \begin{enumerate}
 127 \item
 128 First, make the LIEs for the class and instance contexts, which means
 129 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 130 and make LIElistI and LIEI.
 131 \item
 132 Then process each method in turn.
 133 \item
 134 order the instance methods according to the ordering of the class methods
 135 \item
 136 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 137 \item
 138 Create final dictionary function from bindings generated already
 139 \begin{pseudocode}
 140 df = lambda inst_tyvars
 141        lambda LIEI
 142          let Bop1
 143              Bop2
 144              ...
 145              Bopn
 146          and dbinds_super
 147               in <op1,op2,...,opn,sd1,...,sdm>
 148 \end{pseudocode}
 149 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 150 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 151 \end{enumerate}
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Extracting instance decls}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 Gather up the instance declarations from their various sources
 161
 162 \begin{code}
 163 tcInstDecls1 :: PackageInstEnv
 164              -> PersistentRenamerState
 165              -> HomeSymbolTable         -- Contains instances
 166              -> TcEnv                   -- Contains IdInfo for dfun ids
 167              -> (Name -> Maybe Fixity)  -- for deriving Show and Read
 168              -> Module                  -- Module for deriving
 169              -> [TyCon]
 170              -> [RenamedHsDecl]
 171              -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
 172
 173 tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
 174   = let
 175         inst_decls = [inst_decl | InstD inst_decl <- decls]
 176         clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
 177     in
 178         -- (1) Do the ordinary instance declarations
 179     mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls       `thenNF_Tc` \ inst_infos ->
 180
 181         -- (2) Instances from generic class declarations
 182     getGenericInstances mod clas_decls          `thenTc` \ generic_inst_info ->
 183
 184         -- Next, construct the instance environment so far, consisting of
 185         --      a) cached non-home-package InstEnv (gotten from pcs)    pcs_insts pcs
 186         --      b) imported instance decls (not in the home package)    inst_env1
 187         --      c) other modules in this package (gotten from hst)      inst_env2
 188         --      d) local instance decls                                 inst_env3
 189         --      e) generic instances                                    inst_env4
 190         -- The result of (b) replaces the cached InstEnv in the PCS
 191     let
 192         (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)
 193
 194         imported_dfuns   = map (tcAddImportedIdInfo unf_env . iDFunId)
 195                                imported_inst_info
 196         hst_dfuns        = foldModuleEnv ((++) . md_insts) [] hst
 197     in
 198     addInstDFuns inst_env0 imported_dfuns       `thenNF_Tc` \ inst_env1 ->
 199     addInstDFuns inst_env1 hst_dfuns            `thenNF_Tc` \ inst_env2 ->
 200     addInstInfos inst_env2 local_inst_info      `thenNF_Tc` \ inst_env3 ->
 201     addInstInfos inst_env3 generic_inst_info    `thenNF_Tc` \ inst_env4 ->
 202
 203         -- (3) Compute instances from "deriving" clauses;
 204         --     note that we only do derivings for things in this module;
 205         --     we ignore deriving decls from interfaces!
 206         -- This stuff computes a context for the derived instance decl, so it
 207         -- needs to know about all the instances possible; hecne inst_env4
 208     tcDeriving prs mod inst_env4 get_fixity tycons      `thenTc` \ (deriv_inst_info, deriv_binds) ->
 209     addInstInfos inst_env4 deriv_inst_info              `thenNF_Tc` \ final_inst_env ->
 210
 211     returnTc (inst_env1,
 212               final_inst_env,
 213               generic_inst_info ++ deriv_inst_info ++ local_inst_info,
 214               deriv_binds)
 215
 216 addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
 217 addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
 218
 219 addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
 220 addInstDFuns dfuns infos
 221   = getDOptsTc                          `thenTc` \ dflags ->
 222     extendInstEnv dflags dfuns infos    `bind`   \ (inst_env', errs) ->
 223     addErrsTc errs                      `thenNF_Tc_`
 224     returnTc inst_env'
 225   where
 226     bind x f = f x
 227
 228 \end{code}
 229
 230 \begin{code}
 231 tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
 232 -- Deal with a single instance declaration
 233 tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
 234   =     -- Prime error recovery, set source location
 235     recoverNF_Tc (returnNF_Tc [])       $
 236     tcAddSrcLoc src_loc                 $
 237
 238         -- Type-check all the stuff before the "where"
 239     tcHsSigType poly_ty                 `thenTc` \ poly_ty' ->
 240     let
 241         (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
 242     in
 243
 244     (case maybe_dfun_name of
 245         Nothing ->      -- A source-file instance declaration
 246
 247                 -- Check for respectable instance type, and context
 248                 -- but only do this for non-imported instance decls.
 249                 -- Imported ones should have been checked already, and may indeed
 250                 -- contain something illegal in normal Haskell, notably
 251                 --      instance CCallable [Char]
 252             scrutiniseInstanceHead clas inst_tys                `thenNF_Tc_`
 253             mapNF_Tc scrutiniseInstanceConstraint theta         `thenNF_Tc_`
 254
 255                 -- Make the dfun id and return it
 256             newDFunName mod clas inst_tys src_loc               `thenNF_Tc` \ dfun_name ->
 257             returnNF_Tc (True, dfun_name)
 258
 259         Just dfun_name ->       -- An interface-file instance declaration
 260                 -- Make the dfun id
 261             returnNF_Tc (False, dfun_name)
 262     )                                           `thenNF_Tc` \ (is_local, dfun_name) ->
 263
 264     let
 265         dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
 266     in
 267     returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id,
 268                          iBinds = binds,    iPrags = uprags }]
 269 \end{code}
 270
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsection{Extracting generic instance declaration from class declarations}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 @getGenericInstances@ extracts the generic instance declarations from a class
 279 declaration.  For exmaple
 280
 281         class C a where
 282           op :: a -> a
 283
 284           op{ x+y } (Inl v)   = ...
 285           op{ x+y } (Inr v)   = ...
 286           op{ x*y } (v :*: w) = ...
 287           op{ 1   } Unit      = ...
 288
 289 gives rise to the instance declarations
 290
 291         instance C (x+y) where
 292           op (Inl v)   = ...
 293           op (Inr v)   = ...
 294
 295         instance C (x*y) where
 296           op (v :*: w) = ...
 297
 298         instance C 1 where
 299           op Unit      = ...
 300
 301
 302 \begin{code}
 303 getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo]
 304 getGenericInstances mod class_decls
 305   = mapTc (get_generics mod) class_decls                `thenTc` \ gen_inst_infos ->
 306     let
 307         gen_inst_info = concat gen_inst_infos
 308     in
 309     getDOptsTc                                          `thenTc`  \ dflags ->
 310     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 311                       (vcat (map pprInstInfo gen_inst_info)))
 312                                                         `thenNF_Tc_`
 313     returnTc gen_inst_info
 314
 315 get_generics mod decl@(ClassDecl context class_name tyvar_names
 316                                  fundeps class_sigs def_methods
 317                                  name_list loc)
 318   | null groups
 319   = returnTc [] -- The comon case:
 320                 --      no generic default methods, or
 321                 --      its an imported class decl (=> has no methods at all)
 322
 323   | otherwise   -- A local class decl with generic default methods
 324   = recoverNF_Tc (returnNF_Tc [])                               $
 325     tcAddDeclCtxt decl                                          $
 326     tcLookupClass class_name                                    `thenTc` \ clas ->
 327
 328         -- Make an InstInfo out of each group
 329     mapTc (mkGenericInstance mod clas loc) groups               `thenTc` \ inst_infos ->
 330
 331         -- Check that there is only one InstInfo for each type constructor
 332         -- The main way this can fail is if you write
 333         --      f {| a+b |} ... = ...
 334         --      f {| x+y |} ... = ...
 335         -- Then at this point we'll have an InstInfo for each
 336     let
 337         tc_inst_infos :: [(TyCon, InstInfo)]
 338         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 339
 340         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 341                               length group > 1]
 342         get_uniq (tc,_) = getUnique tc
 343     in
 344     mapTc (addErrTc . dupGenericInsts) bad_groups       `thenTc_`
 345
 346         -- Check that there is an InstInfo for each generic type constructor
 347     let
 348         missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
 349     in
 350     checkTc (null missing) (missingGenericInstances missing)    `thenTc_`
 351
 352     returnTc inst_infos
 353
 354   where
 355         -- Group the declarations by type pattern
 356         groups :: [(RenamedHsType, RenamedMonoBinds)]
 357         groups = assocElts (getGenericBinds def_methods)
 358
 359
 360 ---------------------------------
 361 getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
 362   -- Takes a group of method bindings, finds the generic ones, and returns
 363   -- them in finite map indexed by the type parameter in the definition.
 364
 365 getGenericBinds EmptyMonoBinds    = emptyAssoc
 366 getGenericBinds (AndMonoBinds m1 m2)
 367   = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
 368
 369 getGenericBinds (FunMonoBind id infixop matches loc)
 370   = mapAssoc wrap (foldr add emptyAssoc matches)
 371   where
 372     add match env = case maybeGenericMatch match of
 373                       Nothing           -> env
 374                       Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
 375
 376     wrap ms = FunMonoBind id infixop ms loc
 377
 378 ---------------------------------
 379 mkGenericInstance :: Module -> Class -> SrcLoc
 380                   -> (RenamedHsType, RenamedMonoBinds)
 381                   -> TcM InstInfo
 382
 383 mkGenericInstance mod clas loc (hs_ty, binds)
 384   -- Make a generic instance declaration
 385   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 386
 387   =     -- Extract the universally quantified type variables
 388     tcTyVars (nameSetToList (extractHsTyVars hs_ty))
 389              (kcHsSigType hs_ty)                `thenTc` \ tyvars ->
 390     tcExtendTyVarEnv tyvars                                     $
 391
 392         -- Type-check the instance type, and check its form
 393     tcHsSigType hs_ty                           `thenTc` \ inst_ty ->
 394     checkTc (validGenericInstanceType inst_ty)
 395             (badGenericInstanceType binds)      `thenTc_`
 396
 397         -- Make the dictionary function.
 398     newDFunName mod clas [inst_ty] loc          `thenNF_Tc` \ dfun_name ->
 399     let
 400         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 401         inst_tys   = [inst_ty]
 402         dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
 403     in
 404
 405     returnTc (InstInfo { iLocal = True, iDFunId = dfun_id,
 406                          iBinds = binds, iPrags = [] })
 407 \end{code}
 408
 409
 410 %************************************************************************
 411 %*                                                                      *
 412 \subsection{Type-checking instance declarations, pass 2}
 413 %*                                                                      *
 414 %************************************************************************
 415
 416 \begin{code}
 417 tcInstDecls2 :: [InstInfo]
 418              -> NF_TcM (LIE, TcMonoBinds)
 419
 420 tcInstDecls2 inst_decls
 421 --  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 422   = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 423           (map tcInstDecl2 inst_decls)
 424   where
 425     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 426                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 427                       returnNF_Tc (lie1 `plusLIE` lie2,
 428                                    binds1 `AndMonoBinds` binds2)
 429 \end{code}
 430
 431 ======= New documentation starts here (Sept 92)  ==============
 432
 433 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 434 the dictionary function for this instance declaration.  For example
 435 \begin{verbatim}
 436         instance Foo a => Foo [a] where
 437                 op1 x = ...
 438                 op2 y = ...
 439 \end{verbatim}
 440 might generate something like
 441 \begin{verbatim}
 442         dfun.Foo.List dFoo_a = let op1 x = ...
 443                                    op2 y = ...
 444                                in
 445                                    Dict [op1, op2]
 446 \end{verbatim}
 447
 448 HOWEVER, if the instance decl has no context, then it returns a
 449 bigger @HsBinds@ with declarations for each method.  For example
 450 \begin{verbatim}
 451         instance Foo [a] where
 452                 op1 x = ...
 453                 op2 y = ...
 454 \end{verbatim}
 455 might produce
 456 \begin{verbatim}
 457         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 458         const.Foo.op1.List a x = ...
 459         const.Foo.op2.List a y = ...
 460 \end{verbatim}
 461 This group may be mutually recursive, because (for example) there may
 462 be no method supplied for op2 in which case we'll get
 463 \begin{verbatim}
 464         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 465 \end{verbatim}
 466 that is, the default method applied to the dictionary at this type.
 467
 468 What we actually produce in either case is:
 469
 470         AbsBinds [a] [dfun_theta_dicts]
 471                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 472                  { d = (sd1,sd2, ..., op1, op2, ...)
 473                    op1 = ...
 474                    op2 = ...
 475                  }
 476
 477 The "maybe" says that we only ask AbsBinds to make global constant methods
 478 if the dfun_theta is empty.
 479
 480
 481 For an instance declaration, say,
 482
 483         instance (C1 a, C2 b) => C (T a b) where
 484                 ...
 485
 486 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 487 function whose type is
 488
 489         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 490
 491 Notice that we pass it the superclass dictionaries at the instance type; this
 492 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 493 is the @dfun_theta@ below.
 494
 495 First comes the easy case of a non-local instance decl.
 496
 497 \begin{code}
 498 tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
 499
 500 tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
 501                         iBinds = monobinds, iPrags = uprags })
 502   | not is_local
 503   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 504
 505   | otherwise
 506   =      -- Prime error recovery
 507     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 508     tcAddSrcLoc (getSrcLoc dfun_id)                        $
 509
 510         -- Instantiate the instance decl with tc-style type variables
 511     tcInstId dfun_id            `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
 512     let
 513         (clas, inst_tys') = splitDictTy dict_ty'
 514         origin            = InstanceDeclOrigin
 515
 516         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 517
 518         dm_ids    = [dm_id | (_, DefMeth dm_id) <- op_items]
 519         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 520
 521         -- Instantiate the super-class context with inst_tys
 522         sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
 523
 524         -- Find any definitions in monobinds that aren't from the class
 525         bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
 526
 527         -- The type variable from the dict fun actually scope
 528         -- over the bindings.  They were gotten from
 529         -- the original instance declaration
 530         (inst_tyvars, _) = splitForAllTys (idType dfun_id)
 531     in
 532          -- Check that all the method bindings come from this class
 533     mapTc (addErrTc . badMethodErr clas) bad_bndrs              `thenNF_Tc_`
 534
 535          -- Create dictionary Ids from the specified instance contexts.
 536     newClassDicts origin sc_theta'              `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 537     newDicts origin dfun_theta'                 `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 538     newClassDicts origin [(clas,inst_tys')]     `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 539
 540     tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
 541         tcExtendGlobalValEnv dm_ids (
 542                 -- Default-method Ids may be mentioned in synthesised RHSs
 543
 544         mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
 545                                      dfun_theta'
 546                                      monobinds uprags True)
 547                        op_items
 548     ))                  `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 549
 550         -- Deal with SPECIALISE instance pragmas by making them
 551         -- look like SPECIALISE pragmas for the dfun
 552     let
 553         dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
 554     in
 555     tcExtendGlobalValEnv [dfun_id] (
 556         tcSpecSigs dfun_prags
 557     )                                   `thenTc` \ (prag_binds, prag_lie) ->
 558
 559         -- Check the overloading constraints of the methods and superclasses
 560
 561         -- tcMethodBind has checked that the class_tyvars havn't
 562         -- been unified with each other or another type, but we must
 563         -- still zonk them before passing them to tcSimplifyAndCheck
 564     zonkTcSigTyVars inst_tyvars'        `thenNF_Tc` \ zonked_inst_tyvars ->
 565     let
 566         inst_tyvars_set = mkVarSet zonked_inst_tyvars
 567
 568         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 569
 570                  -- These insts are in scope; quite a few, eh?
 571         avail_insts = this_dict                 `plusLIE`
 572                       dfun_arg_dicts            `plusLIE`
 573                       sc_dicts                  `plusLIE`
 574                       unionManyBags meth_lies
 575
 576         methods_lie = plusLIEs insts_needed_s
 577     in
 578
 579         -- Ditto method bindings
 580     tcAddErrCtxt methodCtxt (
 581       tcSimplifyAndCheck
 582                  (ptext SLIT("instance declaration context"))
 583                  inst_tyvars_set                        -- Local tyvars
 584                  avail_insts
 585                  methods_lie
 586     )                                            `thenTc` \ (const_lie1, lie_binds1) ->
 587
 588         -- Now do the simplification again, this time to get the
 589         -- bindings; this time we use an enhanced "avails"
 590         -- Ignore errors because they come from the *previous* tcSimplify
 591     discardErrsTc (
 592         tcSimplifyAndCheck
 593                  (ptext SLIT("instance declaration context"))
 594                  inst_tyvars_set
 595                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 596                                         -- get bound by just selecting from this_dict!!
 597                  sc_dicts
 598     )                                            `thenTc` \ (const_lie2, lie_binds2) ->
 599
 600
 601         -- Create the result bindings
 602     let
 603         dict_constr   = classDataCon clas
 604         scs_and_meths = sc_dict_ids ++ meth_ids
 605
 606         dict_rhs
 607           | null scs_and_meths
 608           =     -- Blatant special case for CCallable, CReturnable
 609                 -- If the dictionary is empty then we should never
 610                 -- select anything from it, so we make its RHS just
 611                 -- emit an error message.  This in turn means that we don't
 612                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 613                 -- Hardly beautiful, but only three extra lines.
 614             HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
 615                   (HsLit (HsString msg))
 616
 617           | otherwise   -- The common case
 618           = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
 619                 -- We don't produce a binding for the dict_constr; instead we
 620                 -- rely on the simplifier to unfold this saturated application
 621                 -- We do this rather than generate an HsCon directly, because
 622                 -- it means that the special cases (e.g. dictionary with only one
 623                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 624                 -- than needing to be repeated here.
 625
 626           where
 627             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 628
 629         dict_bind    = VarMonoBind this_dict_id dict_rhs
 630         method_binds = andMonoBindList method_binds_s
 631
 632         main_bind
 633           = AbsBinds
 634                  zonked_inst_tyvars
 635                  dfun_arg_dicts_ids
 636                  [(inst_tyvars', dfun_id, this_dict_id)]
 637                  emptyNameSet           -- No inlines (yet)
 638                  (lie_binds1    `AndMonoBinds`
 639                   lie_binds2    `AndMonoBinds`
 640                   method_binds  `AndMonoBinds`
 641                   dict_bind)
 642     in
 643     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 644               main_bind `AndMonoBinds` prag_binds)
 645 \end{code}
 646
 647
 648 %************************************************************************
 649 %*                                                                      *
 650 \subsection{Checking for a decent instance type}
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
 655 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 656
 657 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 658 flag is on, or (2)~the instance is imported (they must have been
 659 compiled elsewhere). In these cases, we let them go through anyway.
 660
 661 We can also have instances for functions: @instance Foo (a -> b) ...@.
 662
 663 \begin{code}
 664 scrutiniseInstanceConstraint pred
 665   = getDOptsTc `thenTc` \ dflags -> case () of
 666     ()
 667      |  dopt Opt_AllowUndecidableInstances dflags
 668      -> returnNF_Tc ()
 669
 670      |  Just (clas,tys) <- getClassTys_maybe pred,
 671         all isTyVarTy tys
 672      -> returnNF_Tc ()
 673
 674      |  otherwise
 675      -> addErrTc (instConstraintErr pred)
 676
 677 scrutiniseInstanceHead clas inst_taus
 678   = getDOptsTc `thenTc` \ dflags -> case () of
 679     ()
 680      |  -- CCALL CHECK
 681         -- A user declaration of a CCallable/CReturnable instance
 682         -- must be for a "boxed primitive" type.
 683         (clas `hasKey` cCallableClassKey
 684             && not (ccallable_type dflags first_inst_tau))
 685         ||
 686         (clas `hasKey` cReturnableClassKey
 687             && not (creturnable_type first_inst_tau))
 688      -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 689
 690         -- DERIVING CHECK
 691         -- It is obviously illegal to have an explicit instance
 692         -- for something that we are also planning to `derive'
 693      |  maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
 694      -> addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 695            -- Kind check will have ensured inst_taus is of length 1
 696
 697         -- Allow anything for AllowUndecidableInstances
 698      |  dopt Opt_AllowUndecidableInstances dflags
 699      -> returnNF_Tc ()
 700
 701         -- If GlasgowExts then check at least one isn't a type variable
 702      |  dopt Opt_GlasgowExts dflags
 703      -> if   all isTyVarTy inst_taus
 704         then addErrTc (instTypeErr clas inst_taus
 705              (text "There must be at least one non-type-variable in the instance head"))
 706         else returnNF_Tc ()
 707
 708         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 709      |  not (length inst_taus == 1 &&
 710              maybeToBool maybe_tycon_app &&     -- Yes, there's a type constuctor
 711              not (isSynTyCon tycon) &&          -- ...but not a synonym
 712              all isTyVarTy arg_tys &&           -- Applied to type variables
 713              length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
 714              -- This last condition checks that all the type variables are distinct
 715             )
 716      ->  addErrTc (instTypeErr clas inst_taus
 717                      (text "the instance type must be of form (T a b c)" $$
 718                       text "where T is not a synonym, and a,b,c are distinct type variables")
 719          )
 720
 721      |  otherwise
 722      -> returnNF_Tc ()
 723
 724   where
 725     (first_inst_tau : _)       = inst_taus
 726
 727         -- Stuff for algebraic or -> type
 728     maybe_tycon_app       = splitTyConApp_maybe first_inst_tau
 729     Just (tycon, arg_tys) = maybe_tycon_app
 730
 731         -- Stuff for an *algebraic* data type
 732     alg_tycon_app_maybe    = splitAlgTyConApp_maybe first_inst_tau
 733                                 -- The "Alg" part looks through synonyms
 734     Just (alg_tycon, _, _) = alg_tycon_app_maybe
 735
 736     ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
 737     creturnable_type        ty = isFFIResultTy ty
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsection{Error messages}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 tcAddDeclCtxt decl thing_inside
 749   = tcAddSrcLoc loc     $
 750     tcAddErrCtxt ctxt   $
 751     thing_inside
 752   where
 753      (name, loc, thing)
 754         = case decl of
 755             (ClassDecl _ name _ _ _ _ _ loc)         -> (name, loc, "class")
 756             (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
 757             (TyData NewType  _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
 758             (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
 759
 760      ctxt = hsep [ptext SLIT("In the"), text thing,
 761                   ptext SLIT("declaration for"), quotes (ppr name)]
 762 \end{code}
 763
 764 \begin{code}
 765 instConstraintErr pred
 766   = hang (ptext SLIT("Illegal constraint") <+>
 767           quotes (pprPred pred) <+>
 768           ptext SLIT("in instance context"))
 769          4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
 770
 771 badGenericInstanceType binds
 772   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 773           nest 4 (ppr binds)]
 774
 775 missingGenericInstances missing
 776   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 777
 778
 779
 780 dupGenericInsts tc_inst_infos
 781   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 782           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 783           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 784     ]
 785   where
 786     ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
 787
 788 instTypeErr clas tys msg
 789   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 790          nest 4 (parens msg)
 791     ]
 792
 793 derivingWhenInstanceExistsErr clas tycon
 794   = hang (hsep [ptext SLIT("Deriving class"),
 795                        quotes (ppr clas),
 796                        ptext SLIT("type"), quotes (ppr tycon)])
 797          4 (ptext SLIT("when an explicit instance exists"))
 798
 799 nonBoxedPrimCCallErr clas inst_ty
 800   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 801          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 802                         ppr inst_ty])
 803
 804 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 805 \end{code}
 806
 807