ghc/compiler/typecheck/TcInstDcls.lhs

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