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                           unUsgTy, 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 (foldr add emptyAssoc matches)
 373   where
 374     add match env = 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         -- Ditto method bindings
 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         -- Now do the simplification again, this time to get the
 591         -- bindings; this time we use an enhanced "avails"
 592         -- Ignore errors because they come from the *previous* tcSimplify
 593     discardErrsTc (
 594         tcSimplifyAndCheck
 595                  (ptext SLIT("instance declaration context"))
 596                  inst_tyvars_set
 597                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 598                                         -- get bound by just selecting from this_dict!!
 599                  sc_dicts
 600     )                                            `thenTc` \ (const_lie2, lie_binds2) ->
 601
 602
 603         -- Create the result bindings
 604     let
 605         dict_constr   = classDataCon clas
 606         scs_and_meths = sc_dict_ids ++ meth_ids
 607
 608         dict_rhs
 609           | null scs_and_meths
 610           =     -- Blatant special case for CCallable, CReturnable
 611                 -- If the dictionary is empty then we should never
 612                 -- select anything from it, so we make its RHS just
 613                 -- emit an error message.  This in turn means that we don't
 614                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 615                 -- Hardly beautiful, but only three extra lines.
 616             HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
 617                   (HsLit (HsString msg))
 618
 619           | otherwise   -- The common case
 620           = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
 621                 -- We don't produce a binding for the dict_constr; instead we
 622                 -- rely on the simplifier to unfold this saturated application
 623                 -- We do this rather than generate an HsCon directly, because
 624                 -- it means that the special cases (e.g. dictionary with only one
 625                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 626                 -- than needing to be repeated here.
 627
 628           where
 629             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 630
 631         dict_bind    = VarMonoBind this_dict_id dict_rhs
 632         method_binds = andMonoBindList method_binds_s
 633
 634         main_bind
 635           = AbsBinds
 636                  zonked_inst_tyvars
 637                  dfun_arg_dicts_ids
 638                  [(inst_tyvars', dfun_id, this_dict_id)]
 639                  emptyNameSet           -- No inlines (yet)
 640                  (lie_binds1    `AndMonoBinds`
 641                   lie_binds2    `AndMonoBinds`
 642                   method_binds  `AndMonoBinds`
 643                   dict_bind)
 644     in
 645     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 646               main_bind `AndMonoBinds` prag_binds)
 647 \end{code}
 648
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection{Checking for a decent instance type}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
 657 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 658
 659 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 660 flag is on, or (2)~the instance is imported (they must have been
 661 compiled elsewhere). In these cases, we let them go through anyway.
 662
 663 We can also have instances for functions: @instance Foo (a -> b) ...@.
 664
 665 \begin{code}
 666 scrutiniseInstanceConstraint pred
 667   = getDOptsTc `thenTc` \ dflags -> case () of
 668     ()
 669      |  dopt Opt_AllowUndecidableInstances dflags
 670      -> returnNF_Tc ()
 671
 672      |  Just (clas,tys) <- getClassTys_maybe pred,
 673         all isTyVarTy tys
 674      -> returnNF_Tc ()
 675
 676      |  otherwise
 677      -> addErrTc (instConstraintErr pred)
 678
 679 scrutiniseInstanceHead clas inst_taus
 680   = getDOptsTc `thenTc` \ dflags -> case () of
 681     ()
 682      |  -- CCALL CHECK
 683         -- A user declaration of a CCallable/CReturnable instance
 684         -- must be for a "boxed primitive" type.
 685         (clas `hasKey` cCallableClassKey
 686             && not (ccallable_type dflags first_inst_tau))
 687         ||
 688         (clas `hasKey` cReturnableClassKey
 689             && not (creturnable_type first_inst_tau))
 690      -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 691
 692         -- Allow anything for AllowUndecidableInstances
 693      |  dopt Opt_AllowUndecidableInstances dflags
 694      -> returnNF_Tc ()
 695
 696         -- If GlasgowExts then check at least one isn't a type variable
 697      |  dopt Opt_GlasgowExts dflags
 698      -> if   all isTyVarTy inst_taus
 699         then addErrTc (instTypeErr clas inst_taus
 700              (text "There must be at least one non-type-variable in the instance head"))
 701         else returnNF_Tc ()
 702
 703         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 704      |  not (length inst_taus == 1 &&
 705              maybeToBool maybe_tycon_app &&     -- Yes, there's a type constuctor
 706              not (isSynTyCon tycon) &&          -- ...but not a synonym
 707              all isTyVarTy arg_tys &&           -- Applied to type variables
 708              length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
 709              -- This last condition checks that all the type variables are distinct
 710             )
 711      ->  addErrTc (instTypeErr clas inst_taus
 712                      (text "the instance type must be of form (T a b c)" $$
 713                       text "where T is not a synonym, and a,b,c are distinct type variables")
 714          )
 715
 716      |  otherwise
 717      -> returnNF_Tc ()
 718
 719   where
 720     (first_inst_tau : _)       = inst_taus
 721
 722         -- Stuff for algebraic or -> type
 723     maybe_tycon_app       = splitTyConApp_maybe first_inst_tau
 724     Just (tycon, arg_tys) = maybe_tycon_app
 725
 726         -- Stuff for an *algebraic* data type
 727     alg_tycon_app_maybe    = splitAlgTyConApp_maybe first_inst_tau
 728                                 -- The "Alg" part looks through synonyms
 729     Just (alg_tycon, _, _) = alg_tycon_app_maybe
 730
 731     ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
 732     creturnable_type        ty = isFFIResultTy ty
 733 \end{code}
 734
 735
 736 %************************************************************************
 737 %*                                                                      *
 738 \subsection{Error messages}
 739 %*                                                                      *
 740 %************************************************************************
 741
 742 \begin{code}
 743 tcAddDeclCtxt decl thing_inside
 744   = tcAddSrcLoc loc     $
 745     tcAddErrCtxt ctxt   $
 746     thing_inside
 747   where
 748      (name, loc, thing)
 749         = case decl of
 750             (ClassDecl _ name _ _ _ _ _ loc)         -> (name, loc, "class")
 751             (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
 752             (TyData NewType  _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
 753             (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
 754
 755      ctxt = hsep [ptext SLIT("In the"), text thing,
 756                   ptext SLIT("declaration for"), quotes (ppr name)]
 757 \end{code}
 758
 759 \begin{code}
 760 instConstraintErr pred
 761   = hang (ptext SLIT("Illegal constraint") <+>
 762           quotes (pprPred pred) <+>
 763           ptext SLIT("in instance context"))
 764          4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
 765
 766 badGenericInstanceType binds
 767   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 768           nest 4 (ppr binds)]
 769
 770 missingGenericInstances missing
 771   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 772
 773
 774
 775 dupGenericInsts tc_inst_infos
 776   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 777           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 778           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 779     ]
 780   where
 781     ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
 782
 783 instTypeErr clas tys msg
 784   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 785          nest 4 (parens msg)
 786     ]
 787
 788 nonBoxedPrimCCallErr clas inst_ty
 789   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 790          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 791                         ppr inst_ty])
 792
 793 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 794 \end{code}
 795
 796