ghc/compiler/typecheck/TcInstDcls.lhs

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