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