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