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