ghc/compiler/typecheck/TcInstDcls.lhs

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