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