ghc/compiler/typecheck/TcInstDcls.lhs

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