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, isLocalInst,
  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         ( PersistentCompilerState(..), 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             ( isLocallyDefined )
  52 import NameSet          ( emptyNameSet, nameSetToList )
  53 import PrelInfo         ( eRROR_ID )
  54 import PprType          ( pprConstraint, pprPred )
  55 import TyCon            ( TyCon, isSynTyCon, tyConDerivings )
  56 import Type             ( mkTyVarTys, splitDFunTy, isTyVarTy,
  57                           splitTyConApp_maybe, splitDictTy,
  58                           splitAlgTyConApp_maybe,
  59                           unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
  60                           getClassTys_maybe
  61                         )
  62 import Subst            ( mkTopTyVarSubst, substClasses, substTheta )
  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 local_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)
 193            = partition (isLocalInst mod) (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 local_tycons        `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     extendInstEnv dflags dfuns infos    `bind`   \ (inst_env', errs) ->
 224     addErrsTc errs                      `thenNF_Tc_`
 225     returnTc inst_env'
 226   where
 227     bind x f = f x
 228
 229 \end{code}
 230
 231 \begin{code}
 232 tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
 233 -- Deal with a single instance declaration
 234 tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
 235   =     -- Prime error recovery, set source location
 236     recoverNF_Tc (returnNF_Tc [])       $
 237     tcAddSrcLoc src_loc                 $
 238
 239         -- Type-check all the stuff before the "where"
 240     tcHsSigType poly_ty                 `thenTc` \ poly_ty' ->
 241     let
 242         (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
 243     in
 244
 245     (case maybe_dfun_name of
 246         Nothing ->      -- A source-file instance declaration
 247
 248                 -- Check for respectable instance type, and context
 249                 -- but only do this for non-imported instance decls.
 250                 -- Imported ones should have been checked already, and may indeed
 251                 -- contain something illegal in normal Haskell, notably
 252                 --      instance CCallable [Char]
 253             scrutiniseInstanceHead clas inst_tys                `thenNF_Tc_`
 254             mapNF_Tc scrutiniseInstanceConstraint theta         `thenNF_Tc_`
 255
 256                 -- Make the dfun id and return it
 257             newDFunName mod clas inst_tys src_loc               `thenNF_Tc` \ dfun_name ->
 258             returnNF_Tc (True, mkDictFunId dfun_name clas tyvars inst_tys theta)
 259
 260         Just dfun_name ->       -- An interface-file instance declaration
 261                 -- Make the dfun id
 262             returnNF_Tc (False, mkDictFunId dfun_name clas tyvars inst_tys theta)
 263     )                                           `thenNF_Tc` \ (is_local, dfun_id) ->
 264
 265     returnTc [InstInfo { iLocal = is_local,
 266                          iClass = clas, iTyVars = tyvars, iTys = inst_tys,
 267                          iTheta = theta, iDFunId = dfun_id,
 268                          iBinds = binds, iLoc = src_loc, 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         bad_groups = [group | group <- equivClassesByUniq get_uniq inst_infos,
 338                               length group > 1]
 339         get_uniq inst = getUnique (simpleInstInfoTyCon inst)
 340     in
 341     mapTc (addErrTc . dupGenericInsts) bad_groups       `thenTc_`
 342
 343         -- Check that there is an InstInfo for each generic type constructor
 344     let
 345         missing = genericTyCons `minusList` map simpleInstInfoTyCon inst_infos
 346     in
 347     checkTc (null missing) (missingGenericInstances missing)    `thenTc_`
 348
 349     returnTc inst_infos
 350
 351   where
 352         -- Group the declarations by type pattern
 353         groups :: [(RenamedHsType, RenamedMonoBinds)]
 354         groups = assocElts (getGenericBinds def_methods)
 355
 356
 357 ---------------------------------
 358 getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
 359   -- Takes a group of method bindings, finds the generic ones, and returns
 360   -- them in finite map indexed by the type parameter in the definition.
 361
 362 getGenericBinds EmptyMonoBinds    = emptyAssoc
 363 getGenericBinds (AndMonoBinds m1 m2)
 364   = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
 365
 366 getGenericBinds (FunMonoBind id infixop matches loc)
 367   = mapAssoc wrap (foldr add emptyAssoc matches)
 368   where
 369     add match env = case maybeGenericMatch match of
 370                       Nothing           -> env
 371                       Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
 372
 373     wrap ms = FunMonoBind id infixop ms loc
 374
 375 ---------------------------------
 376 mkGenericInstance :: Module -> Class -> SrcLoc
 377                   -> (RenamedHsType, RenamedMonoBinds)
 378                   -> TcM InstInfo
 379
 380 mkGenericInstance mod clas loc (hs_ty, binds)
 381   -- Make a generic instance declaration
 382   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 383
 384   =     -- Extract the universally quantified type variables
 385     tcTyVars (nameSetToList (extractHsTyVars hs_ty))
 386              (kcHsSigType hs_ty)                `thenTc` \ tyvars ->
 387     tcExtendTyVarEnv tyvars                                     $
 388
 389         -- Type-check the instance type, and check its form
 390     tcHsSigType hs_ty                           `thenTc` \ inst_ty ->
 391     checkTc (validGenericInstanceType inst_ty)
 392             (badGenericInstanceType binds)      `thenTc_`
 393
 394         -- Make the dictionary function.
 395     newDFunName mod clas [inst_ty] loc          `thenNF_Tc` \ dfun_name ->
 396     let
 397         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 398         inst_tys   = [inst_ty]
 399         dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
 400     in
 401
 402     returnTc (InstInfo { iLocal = True,
 403                          iClass = clas, iTyVars = tyvars, iTys = inst_tys,
 404                          iTheta = inst_theta, iDFunId = dfun_id, iBinds = binds,
 405                          iLoc = loc, iPrags = [] })
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection{Type-checking instance declarations, pass 2}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 \begin{code}
 416 tcInstDecls2 :: [InstInfo]
 417              -> NF_TcM (LIE, TcMonoBinds)
 418
 419 tcInstDecls2 inst_decls
 420 --  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 421   = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 422           (map tcInstDecl2 inst_decls)
 423   where
 424     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 425                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 426                       returnNF_Tc (lie1 `plusLIE` lie2,
 427                                    binds1 `AndMonoBinds` binds2)
 428 \end{code}
 429
 430 ======= New documentation starts here (Sept 92)  ==============
 431
 432 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 433 the dictionary function for this instance declaration.  For example
 434 \begin{verbatim}
 435         instance Foo a => Foo [a] where
 436                 op1 x = ...
 437                 op2 y = ...
 438 \end{verbatim}
 439 might generate something like
 440 \begin{verbatim}
 441         dfun.Foo.List dFoo_a = let op1 x = ...
 442                                    op2 y = ...
 443                                in
 444                                    Dict [op1, op2]
 445 \end{verbatim}
 446
 447 HOWEVER, if the instance decl has no context, then it returns a
 448 bigger @HsBinds@ with declarations for each method.  For example
 449 \begin{verbatim}
 450         instance Foo [a] where
 451                 op1 x = ...
 452                 op2 y = ...
 453 \end{verbatim}
 454 might produce
 455 \begin{verbatim}
 456         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 457         const.Foo.op1.List a x = ...
 458         const.Foo.op2.List a y = ...
 459 \end{verbatim}
 460 This group may be mutually recursive, because (for example) there may
 461 be no method supplied for op2 in which case we'll get
 462 \begin{verbatim}
 463         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 464 \end{verbatim}
 465 that is, the default method applied to the dictionary at this type.
 466
 467 What we actually produce in either case is:
 468
 469         AbsBinds [a] [dfun_theta_dicts]
 470                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 471                  { d = (sd1,sd2, ..., op1, op2, ...)
 472                    op1 = ...
 473                    op2 = ...
 474                  }
 475
 476 The "maybe" says that we only ask AbsBinds to make global constant methods
 477 if the dfun_theta is empty.
 478
 479
 480 For an instance declaration, say,
 481
 482         instance (C1 a, C2 b) => C (T a b) where
 483                 ...
 484
 485 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 486 function whose type is
 487
 488         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 489
 490 Notice that we pass it the superclass dictionaries at the instance type; this
 491 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 492 is the @dfun_theta@ below.
 493
 494 First comes the easy case of a non-local instance decl.
 495
 496 \begin{code}
 497 tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
 498
 499 tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys,
 500                         iTheta = inst_decl_theta, iDFunId = dfun_id,
 501                         iBinds = monobinds, iLoc = locn, iPrags = uprags })
 502   | not (isLocallyDefined dfun_id)
 503   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 504
 505   | otherwise
 506   =      -- Prime error recovery
 507     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 508     tcAddSrcLoc locn                                       $
 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 theta found in the original instance decl
 522         inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
 523                                       inst_decl_theta
 524
 525         -- Instantiate the super-class context with inst_tys
 526         sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
 527
 528         -- Find any definitions in monobinds that aren't from the class
 529         bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
 530     in
 531          -- Check that all the method bindings come from this class
 532     mapTc (addErrTc . badMethodErr clas) bad_bndrs              `thenNF_Tc_`
 533
 534          -- Create dictionary Ids from the specified instance contexts.
 535     newClassDicts origin sc_theta'              `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 536     newDicts origin dfun_theta'                 `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 537     newDicts origin inst_decl_theta'            `thenNF_Tc` \ (inst_decl_dicts, _) ->
 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                                      inst_decl_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         -- Check that we *could* construct the superclass dictionaries,
 589         -- even though we are *actually* going to pass the superclass dicts in;
 590         -- the check ensures that the caller will never have
 591         --a problem building them.
 592     tcAddErrCtxt superClassCtxt (
 593       tcSimplifyAndCheck
 594                  (ptext SLIT("instance declaration context"))
 595                  inst_tyvars_set                -- Local tyvars
 596                  inst_decl_dicts                -- The instance dictionaries available
 597                  sc_dicts                       -- The superclass dicationaries reqd
 598     )                                   `thenTc` \ _ ->
 599                                                 -- Ignore the result; we're only doing
 600                                                 -- this to make sure it can be done.
 601
 602         -- Now do the simplification again, this time to get the
 603         -- bindings; this time we use an enhanced "avails"
 604         -- Ignore errors because they come from the *previous* tcSimplify
 605     discardErrsTc (
 606         tcSimplifyAndCheck
 607                  (ptext SLIT("instance declaration context"))
 608                  inst_tyvars_set
 609                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 610                                         -- get bound by just selecting from this_dict!!
 611                  sc_dicts
 612     )                                            `thenTc` \ (const_lie2, lie_binds2) ->
 613
 614
 615         -- Create the result bindings
 616     let
 617         dict_constr   = classDataCon clas
 618         scs_and_meths = sc_dict_ids ++ meth_ids
 619
 620         dict_rhs
 621           | null scs_and_meths
 622           =     -- Blatant special case for CCallable, CReturnable
 623                 -- If the dictionary is empty then we should never
 624                 -- select anything from it, so we make its RHS just
 625                 -- emit an error message.  This in turn means that we don't
 626                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 627                 -- Hardly beautiful, but only three extra lines.
 628             HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
 629                   (HsLit (HsString msg))
 630
 631           | otherwise   -- The common case
 632           = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
 633                 -- We don't produce a binding for the dict_constr; instead we
 634                 -- rely on the simplifier to unfold this saturated application
 635                 -- We do this rather than generate an HsCon directly, because
 636                 -- it means that the special cases (e.g. dictionary with only one
 637                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 638                 -- than needing to be repeated here.
 639
 640           where
 641             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 642
 643         dict_bind    = VarMonoBind this_dict_id dict_rhs
 644         method_binds = andMonoBindList method_binds_s
 645
 646         main_bind
 647           = AbsBinds
 648                  zonked_inst_tyvars
 649                  dfun_arg_dicts_ids
 650                  [(inst_tyvars', dfun_id, this_dict_id)]
 651                  emptyNameSet           -- No inlines (yet)
 652                  (lie_binds1    `AndMonoBinds`
 653                   lie_binds2    `AndMonoBinds`
 654                   method_binds  `AndMonoBinds`
 655                   dict_bind)
 656     in
 657     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 658               main_bind `AndMonoBinds` prag_binds)
 659 \end{code}
 660
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection{Checking for a decent instance type}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
 669 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 670
 671 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 672 flag is on, or (2)~the instance is imported (they must have been
 673 compiled elsewhere). In these cases, we let them go through anyway.
 674
 675 We can also have instances for functions: @instance Foo (a -> b) ...@.
 676
 677 \begin{code}
 678 scrutiniseInstanceConstraint pred
 679   = getDOptsTc `thenTc` \ dflags -> case () of
 680     ()
 681      |  dopt Opt_AllowUndecidableInstances dflags
 682      -> returnNF_Tc ()
 683
 684      |  Just (clas,tys) <- getClassTys_maybe pred,
 685         all isTyVarTy tys
 686      -> returnNF_Tc ()
 687
 688      |  otherwise
 689      -> addErrTc (instConstraintErr pred)
 690
 691 scrutiniseInstanceHead clas inst_taus
 692   = getDOptsTc `thenTc` \ dflags -> case () of
 693     ()
 694      |  -- CCALL CHECK
 695         -- A user declaration of a CCallable/CReturnable instance
 696         -- must be for a "boxed primitive" type.
 697         (clas `hasKey` cCallableClassKey
 698             && not (ccallable_type dflags first_inst_tau))
 699         ||
 700         (clas `hasKey` cReturnableClassKey
 701             && not (creturnable_type first_inst_tau))
 702      -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 703
 704         -- DERIVING CHECK
 705         -- It is obviously illegal to have an explicit instance
 706         -- for something that we are also planning to `derive'
 707      |  maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
 708      -> addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 709            -- Kind check will have ensured inst_taus is of length 1
 710
 711         -- Allow anything for AllowUndecidableInstances
 712      |  dopt Opt_AllowUndecidableInstances dflags
 713      -> returnNF_Tc ()
 714
 715         -- If GlasgowExts then check at least one isn't a type variable
 716      |  dopt Opt_GlasgowExts dflags
 717      -> if   all isTyVarTy inst_taus
 718         then addErrTc (instTypeErr clas inst_taus
 719              (text "There must be at least one non-type-variable in the instance head"))
 720         else returnNF_Tc ()
 721
 722         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 723      |  not (length inst_taus == 1 &&
 724              maybeToBool maybe_tycon_app &&     -- Yes, there's a type constuctor
 725              not (isSynTyCon tycon) &&          -- ...but not a synonym
 726              all isTyVarTy arg_tys &&           -- Applied to type variables
 727              length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
 728              -- This last condition checks that all the type variables are distinct
 729             )
 730      ->  addErrTc (instTypeErr clas inst_taus
 731                      (text "the instance type must be of form (T a b c)" $$
 732                       text "where T is not a synonym, and a,b,c are distinct type variables")
 733          )
 734
 735      |  otherwise
 736      -> returnNF_Tc ()
 737
 738   where
 739     (first_inst_tau : _)       = inst_taus
 740
 741         -- Stuff for algebraic or -> type
 742     maybe_tycon_app       = splitTyConApp_maybe first_inst_tau
 743     Just (tycon, arg_tys) = maybe_tycon_app
 744
 745         -- Stuff for an *algebraic* data type
 746     alg_tycon_app_maybe    = splitAlgTyConApp_maybe first_inst_tau
 747                                 -- The "Alg" part looks through synonyms
 748     Just (alg_tycon, _, _) = alg_tycon_app_maybe
 749
 750     ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
 751     creturnable_type        ty = isFFIResultTy ty
 752 \end{code}
 753
 754
 755 %************************************************************************
 756 %*                                                                      *
 757 \subsection{Error messages}
 758 %*                                                                      *
 759 %************************************************************************
 760
 761 \begin{code}
 762 tcAddDeclCtxt decl thing_inside
 763   = tcAddSrcLoc loc     $
 764     tcAddErrCtxt ctxt   $
 765     thing_inside
 766   where
 767      (name, loc, thing)
 768         = case decl of
 769             (ClassDecl _ name _ _ _ _ _ loc)         -> (name, loc, "class")
 770             (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
 771             (TyData NewType  _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
 772             (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
 773
 774      ctxt = hsep [ptext SLIT("In the"), text thing,
 775                   ptext SLIT("declaration for"), quotes (ppr name)]
 776 \end{code}
 777
 778 \begin{code}
 779 instConstraintErr pred
 780   = hang (ptext SLIT("Illegal constraint") <+>
 781           quotes (pprPred pred) <+>
 782           ptext SLIT("in instance context"))
 783          4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
 784
 785 badGenericInstanceType binds
 786   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 787           nest 4 (ppr binds)]
 788
 789 missingGenericInstances missing
 790   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 791
 792
 793
 794 dupGenericInsts inst_infos
 795   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 796           nest 4 (vcat (map (ppr . simpleInstInfoTy) inst_infos)),
 797           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 798     ]
 799
 800 instTypeErr clas tys msg
 801   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 802          nest 4 (parens msg)
 803     ]
 804
 805 derivingWhenInstanceExistsErr clas tycon
 806   = hang (hsep [ptext SLIT("Deriving class"),
 807                        quotes (ppr clas),
 808                        ptext SLIT("type"), quotes (ppr tycon)])
 809          4 (ptext SLIT("when an explicit instance exists"))
 810
 811 nonBoxedPrimCCallErr clas inst_ty
 812   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 813          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 814                         ppr inst_ty])
 815
 816 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 817 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
 818 \end{code}
 819
 820