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