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 (
   8         tcInstDecls1,
   9         tcInstDecls2
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HsSyn            ( HsDecl(..), InstDecl(..),
  15                           HsBinds(..), MonoBinds(..), GRHSsAndBinds(..),
  16                           HsExpr(..), InPat(..), HsLit(..), Sig(..),
  17                           collectMonoBinders, andMonoBindList
  18                         )
  19 import RnHsSyn          ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
  20 import TcHsSyn          ( TcMonoBinds, TcIdOcc(..),
  21                           maybeBoxedPrimType, tcIdType
  22                         )
  23
  24 import TcBinds          ( tcPragmaSigs )
  25 import TcClassDcl       ( tcMethodBind, badMethodErr )
  26 import TcMonad
  27 import RnMonad          ( RnNameSupply )
  28 import Inst             ( Inst, InstOrigin(..),
  29                           newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
  30 import TcDeriv          ( tcDeriving )
  31 import TcEnv            ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo, tcInstId )
  32 import TcInstUtil       ( InstInfo(..), classDataCon )
  33 import TcMonoType       ( tcHsType )
  34 import TcSimplify       ( tcSimplifyAndCheck )
  35 import TcType           ( TcTyVar, zonkTcTyVarBndr )
  36
  37 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  38                           foldBag, bagToList, Bag
  39                         )
  40 import CmdLineOpts      ( opt_GlasgowExts, opt_AllowUndecidableInstances )
  41 import Class            ( classBigSig, Class )
  42 import Var              ( setIdInfo, idName, Id, TyVar )
  43 import DataCon          ( isNullaryDataCon, dataConArgTys, dataConId )
  44 import Maybes           ( maybeToBool, catMaybes, expectJust )
  45 import MkId             ( mkDictFunId )
  46 import Name             ( nameOccName, isLocallyDefined, Module,
  47                           NamedThing(..)
  48                         )
  49 import PrelVals         ( eRROR_ID )
  50 import PprType          ( pprConstraint )
  51 import SrcLoc           ( SrcLoc )
  52 import TyCon            ( isSynTyCon, isDataTyCon, tyConDerivings )
  53 import Type             ( Type, isUnLiftedType, mkTyVarTys,
  54                           splitSigmaTy, isTyVarTy,
  55                           splitTyConApp_maybe, splitDictTy_maybe,
  56                           splitAlgTyConApp_maybe,
  57                           tyVarsOfTypes, substFlexiTheta
  58                         )
  59 import VarEnv           ( zipVarEnv )
  60 import VarSet           ( mkVarSet, varSetElems )
  61 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  62 import TysWiredIn       ( stringTy )
  63 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
  64 import Outputable
  65 \end{code}
  66
  67 Typechecking instance declarations is done in two passes. The first
  68 pass, made by @tcInstDecls1@, collects information to be used in the
  69 second pass.
  70
  71 This pre-processed info includes the as-yet-unprocessed bindings
  72 inside the instance declaration.  These are type-checked in the second
  73 pass, when the class-instance envs and GVE contain all the info from
  74 all the instance and value decls.  Indeed that's the reason we need
  75 two passes over the instance decls.
  76
  77
  78 Here is the overall algorithm.
  79 Assume that we have an instance declaration
  80
  81     instance c => k (t tvs) where b
  82
  83 \begin{enumerate}
  84 \item
  85 $LIE_c$ is the LIE for the context of class $c$
  86 \item
  87 $betas_bar$ is the free variables in the class method type, excluding the
  88    class variable
  89 \item
  90 $LIE_cop$ is the LIE constraining a particular class method
  91 \item
  92 $tau_cop$ is the tau type of a class method
  93 \item
  94 $LIE_i$ is the LIE for the context of instance $i$
  95 \item
  96 $X$ is the instance constructor tycon
  97 \item
  98 $gammas_bar$ is the set of type variables of the instance
  99 \item
 100 $LIE_iop$ is the LIE for a particular class method instance
 101 \item
 102 $tau_iop$ is the tau type for this instance of a class method
 103 \item
 104 $alpha$ is the class variable
 105 \item
 106 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 107 \item
 108 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 109 \end{enumerate}
 110
 111 ToDo: Update the list above with names actually in the code.
 112
 113 \begin{enumerate}
 114 \item
 115 First, make the LIEs for the class and instance contexts, which means
 116 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 117 and make LIElistI and LIEI.
 118 \item
 119 Then process each method in turn.
 120 \item
 121 order the instance methods according to the ordering of the class methods
 122 \item
 123 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 124 \item
 125 Create final dictionary function from bindings generated already
 126 \begin{pseudocode}
 127 df = lambda inst_tyvars
 128        lambda LIEI
 129          let Bop1
 130              Bop2
 131              ...
 132              Bopn
 133          and dbinds_super
 134               in <op1,op2,...,opn,sd1,...,sdm>
 135 \end{pseudocode}
 136 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 137 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 138 \end{enumerate}
 139
 140 \begin{code}
 141 tcInstDecls1 :: GlobalValueEnv          -- Contains IdInfo for dfun ids
 142              -> [RenamedHsDecl]
 143              -> Module                  -- module name for deriving
 144              -> RnNameSupply                    -- for renaming derivings
 145              -> TcM s (Bag InstInfo,
 146                        RenamedHsBinds,
 147                        SDoc)
 148
 149 tcInstDecls1 unf_env decls mod_name rn_name_supply
 150   =     -- Do the ordinary instance declarations
 151     mapNF_Tc (tcInstDecl1 unf_env mod_name)
 152              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 153     let
 154         decl_inst_info = unionManyBags inst_info_bags
 155     in
 156         -- Handle "derived" instances; note that we only do derivings
 157         -- for things in this module; we ignore deriving decls from
 158         -- interfaces!
 159     tcDeriving mod_name rn_name_supply decl_inst_info
 160                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 161
 162     let
 163         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 164     in
 165     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 166
 167
 168 tcInstDecl1 :: GlobalValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 169
 170 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 171   =     -- Prime error recovery, set source location
 172     recoverNF_Tc (returnNF_Tc emptyBag) $
 173     tcAddSrcLoc src_loc                 $
 174
 175         -- Type-check all the stuff before the "where"
 176     tcHsType poly_ty                    `thenTc` \ poly_ty' ->
 177     let
 178         (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
 179         (clas, inst_tys)         = case splitDictTy_maybe dict_ty of
 180                                      Nothing   -> pprPanic "tcInstDecl1" (ppr poly_ty)
 181                                      Just pair -> pair
 182     in
 183
 184         -- Check for respectable instance type, and context
 185     scrutiniseInstanceHead clas inst_tys        `thenNF_Tc_`
 186     mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
 187
 188         -- Make the dfun id and constant-method ids
 189     let
 190         dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
 191
 192         -- Add info from interface file
 193         final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
 194     in
 195     returnTc (unitBag (InstInfo clas tyvars inst_tys theta
 196                                 final_dfun_id
 197                                 binds src_loc uprags))
 198 \end{code}
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection{Type-checking instance declarations, pass 2}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 tcInstDecls2 :: Bag InstInfo
 209              -> NF_TcM s (LIE s, TcMonoBinds s)
 210
 211 tcInstDecls2 inst_decls
 212   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 213   where
 214     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 215                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 216                       returnNF_Tc (lie1 `plusLIE` lie2,
 217                                    binds1 `AndMonoBinds` binds2)
 218 \end{code}
 219
 220
 221 ======= New documentation starts here (Sept 92)  ==============
 222
 223 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 224 the dictionary function for this instance declaration.  For example
 225 \begin{verbatim}
 226         instance Foo a => Foo [a] where
 227                 op1 x = ...
 228                 op2 y = ...
 229 \end{verbatim}
 230 might generate something like
 231 \begin{verbatim}
 232         dfun.Foo.List dFoo_a = let op1 x = ...
 233                                    op2 y = ...
 234                                in
 235                                    Dict [op1, op2]
 236 \end{verbatim}
 237
 238 HOWEVER, if the instance decl has no context, then it returns a
 239 bigger @HsBinds@ with declarations for each method.  For example
 240 \begin{verbatim}
 241         instance Foo [a] where
 242                 op1 x = ...
 243                 op2 y = ...
 244 \end{verbatim}
 245 might produce
 246 \begin{verbatim}
 247         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 248         const.Foo.op1.List a x = ...
 249         const.Foo.op2.List a y = ...
 250 \end{verbatim}
 251 This group may be mutually recursive, because (for example) there may
 252 be no method supplied for op2 in which case we'll get
 253 \begin{verbatim}
 254         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 255 \end{verbatim}
 256 that is, the default method applied to the dictionary at this type.
 257
 258 What we actually produce in either case is:
 259
 260         AbsBinds [a] [dfun_theta_dicts]
 261                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 262                  { d = (sd1,sd2, ..., op1, op2, ...)
 263                    op1 = ...
 264                    op2 = ...
 265                  }
 266
 267 The "maybe" says that we only ask AbsBinds to make global constant methods
 268 if the dfun_theta is empty.
 269
 270
 271 For an instance declaration, say,
 272
 273         instance (C1 a, C2 b) => C (T a b) where
 274                 ...
 275
 276 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 277 function whose type is
 278
 279         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 280
 281 Notice that we pass it the superclass dictionaries at the instance type; this
 282 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 283 is the @dfun_theta@ below.
 284
 285 First comes the easy case of a non-local instance decl.
 286
 287 \begin{code}
 288 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
 289
 290 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 291                       inst_decl_theta
 292                       dfun_id monobinds
 293                       locn uprags)
 294   | not (isLocallyDefined dfun_id)
 295   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 296
 297 {-
 298   -- I deleted this "optimisation" because when importing these
 299   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 300   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 301   -- even though it's never used.
 302
 303         -- This case deals with CCallable etc, which don't need any bindings
 304   | isNoDictClass clas
 305   = returnNF_Tc (emptyLIE, EmptyBinds)
 306 -}
 307
 308   | otherwise
 309   =      -- Prime error recovery
 310     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 311     tcAddSrcLoc locn                                       $
 312
 313         -- Instantiate the instance decl with tc-style type variables
 314     tcInstId dfun_id            `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
 315     let
 316         (clas, inst_tys')       = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
 317
 318         origin                  = InstanceDeclOrigin
 319
 320         (class_tyvars,
 321          sc_theta, sc_sel_ids,
 322          op_sel_ids, defm_ids)  = classBigSig clas
 323
 324         -- Instantiate the theta found in the original instance decl
 325         inst_decl_theta' = substFlexiTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
 326                                            inst_decl_theta
 327
 328          -- Instantiate the super-class context with inst_tys
 329         sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys') sc_theta
 330     in
 331          -- Create dictionary Ids from the specified instance contexts.
 332     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 333     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 334     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 335     newDicts origin [(clas,inst_tys')]  `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 336
 337          -- Check that all the method bindings come from this class
 338     let
 339         check_from_this_class (bndr, loc)
 340           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 341           | otherwise                         = tcAddSrcLoc loc $
 342                                                 addErrTc (badMethodErr bndr clas)
 343         sel_names = map getOccName op_sel_ids
 344         bndrs = bagToList (collectMonoBinders monobinds)
 345     in
 346     mapNF_Tc check_from_this_class bndrs                `thenNF_Tc_`
 347
 348     tcExtendGlobalValEnv (catMaybes defm_ids) (
 349
 350                 -- Default-method Ids may be mentioned in synthesised RHSs
 351         mapAndUnzip3Tc (tcMethodBind clas origin inst_tys' inst_tyvars' monobinds uprags True)
 352                        (op_sel_ids `zip` defm_ids)
 353     )                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 354
 355         -- Deal with SPECIALISE instance pragmas
 356     let
 357         dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
 358     in
 359     tcExtendGlobalValEnv [dfun_id] (
 360         tcPragmaSigs dfun_prags
 361     )                                   `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 362
 363         -- Check the overloading constraints of the methods and superclasses
 364
 365         -- tcMethodBind has checked that the class_tyvars havn't
 366         -- been unified with each other or another type, but we must
 367         -- still zonk them
 368     mapNF_Tc zonkTcTyVarBndr inst_tyvars'       `thenNF_Tc` \ zonked_inst_tyvars ->
 369     let
 370         inst_tyvars_set = mkVarSet zonked_inst_tyvars
 371
 372         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 373
 374                  -- These insts are in scope; quite a few, eh?
 375         avail_insts = this_dict                 `plusLIE`
 376                       dfun_arg_dicts            `plusLIE`
 377                       sc_dicts                  `plusLIE`
 378                       unionManyBags meth_lies
 379
 380         methods_lie = plusLIEs insts_needed_s
 381     in
 382
 383         -- Ditto method bindings
 384     tcAddErrCtxt methodCtxt (
 385       tcSimplifyAndCheck
 386                  (ptext SLIT("instance declaration context"))
 387                  inst_tyvars_set                        -- Local tyvars
 388                  avail_insts
 389                  methods_lie
 390     )                                            `thenTc` \ (const_lie1, lie_binds1) ->
 391
 392         -- Check that we *could* construct the superclass dictionaries,
 393         -- even though we are *actually* going to pass the superclass dicts in;
 394         -- the check ensures that the caller will never have
 395         --a problem building them.
 396     tcAddErrCtxt superClassCtxt (
 397       tcSimplifyAndCheck
 398                  (ptext SLIT("instance declaration context"))
 399                  inst_tyvars_set                -- Local tyvars
 400                  inst_decl_dicts                -- The instance dictionaries available
 401                  sc_dicts                       -- The superclass dicationaries reqd
 402     )                                   `thenTc` \ _ ->
 403                                                 -- Ignore the result; we're only doing
 404                                                 -- this to make sure it can be done.
 405
 406         -- Now do the simplification again, this time to get the
 407         -- bindings; this time we use an enhanced "avails"
 408         -- Ignore errors because they come from the *previous* tcSimplify
 409     discardErrsTc (
 410         tcSimplifyAndCheck
 411                  (ptext SLIT("instance declaration context"))
 412                  inst_tyvars_set
 413                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 414                                         -- get bound by just selecting from this_dict!!
 415                  sc_dicts
 416     )                                            `thenTc` \ (const_lie2, lie_binds2) ->
 417
 418
 419         -- Create the result bindings
 420     let
 421         dict_constr   = classDataCon clas
 422         scs_and_meths = sc_dict_ids ++ meth_ids
 423
 424         dict_rhs
 425           | null scs_and_meths
 426           =     -- Blatant special case for CCallable, CReturnable [and Eval  -- sof 5/98]
 427                 -- If the dictionary is empty then we should never
 428                 -- select anything from it, so we make its RHS just
 429                 -- emit an error message.  This in turn means that we don't
 430                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 431                 -- Hardly beautiful, but only three extra lines.
 432             HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
 433                   (HsLitOut (HsString msg) stringTy)
 434
 435           | otherwise   -- The common case
 436           = foldl HsApp (TyApp (HsVar (RealId (dataConId dict_constr))) inst_tys')
 437                                (map HsVar (sc_dict_ids ++ meth_ids))
 438                 -- We don't produce a binding for the dict_constr; instead we
 439                 -- rely on the simplifier to unfold this saturated application
 440                 -- We do this rather than generate an HsCon directly, because
 441                 -- it means that the special cases (e.g. dictionary with only one
 442                 -- member) are dealt with by the common MkId.mkDataConId code rather
 443                 -- than needing to be repeated here.
 444
 445           where
 446             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 447
 448         dict_bind    = VarMonoBind this_dict_id dict_rhs
 449         method_binds = andMonoBindList method_binds_s
 450
 451         final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id))
 452                                 -- Pretty truesome
 453         main_bind
 454           = AbsBinds
 455                  zonked_inst_tyvars
 456                  dfun_arg_dicts_ids
 457                  [(inst_tyvars', RealId final_dfun_id, this_dict_id)]
 458                  (lie_binds1    `AndMonoBinds`
 459                   lie_binds2    `AndMonoBinds`
 460                   method_binds  `AndMonoBinds`
 461                   dict_bind)
 462     in
 463     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 464               main_bind `AndMonoBinds` prag_binds)
 465 \end{code}
 466
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection{Checking for a decent instance type}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
 475 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 476
 477 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 478 flag is on, or (2)~the instance is imported (they must have been
 479 compiled elsewhere). In these cases, we let them go through anyway.
 480
 481 We can also have instances for functions: @instance Foo (a -> b) ...@.
 482
 483 \begin{code}
 484 scrutiniseInstanceConstraint (clas, tys)
 485   |  all isTyVarTy tys
 486   || opt_AllowUndecidableInstances = returnNF_Tc ()
 487   | otherwise                      = addErrTc (instConstraintErr clas tys)
 488
 489 scrutiniseInstanceHead clas inst_taus
 490   |     -- CCALL CHECK (a).... urgh!
 491         -- To verify that a user declaration of a CCallable/CReturnable
 492         -- instance is OK, we must be able to see the constructor(s)
 493         -- of the instance type (see next guard.)
 494         --
 495         -- We flag this separately to give a more precise error msg.
 496         --
 497      (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
 498   && is_alg_tycon_app && not constructors_visible
 499   = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
 500
 501   |     -- CCALL CHECK (b)
 502         -- A user declaration of a CCallable/CReturnable instance
 503         -- must be for a "boxed primitive" type.
 504     (getUnique clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
 505     (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
 506   = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 507
 508         -- DERIVING CHECK
 509         -- It is obviously illegal to have an explicit instance
 510         -- for something that we are also planning to `derive'
 511   | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
 512   = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 513            -- Kind check will have ensured inst_taus is of length 1
 514
 515         -- Allow anything for AllowUndecidableInstances
 516   | opt_AllowUndecidableInstances
 517   = returnNF_Tc ()
 518
 519         -- If GlasgowExts then check at least one isn't a type variable
 520   | opt_GlasgowExts
 521   = if all isTyVarTy inst_taus then
 522         addErrTc (instTypeErr clas inst_taus (text "There must be at least one non-type-variable in the instance head"))
 523     else
 524         returnNF_Tc ()
 525
 526         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 527   |  not (length inst_taus == 1 &&
 528           maybeToBool maybe_tycon_app &&        -- Yes, there's a type constuctor
 529           not (isSynTyCon tycon) &&             -- ...but not a synonym
 530           all isTyVarTy arg_tys &&              -- Applied to type variables
 531           length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
 532                  -- This last condition checks that all the type variables are distinct
 533      )
 534   = addErrTc (instTypeErr clas inst_taus
 535                         (text "the instance type must be of form (T a b c)" $$
 536                          text "where T is not a synonym, and a,b,c are distinct type variables")
 537     )
 538
 539   | otherwise
 540   = returnNF_Tc ()
 541
 542   where
 543     (first_inst_tau : _)       = inst_taus
 544
 545         -- Stuff for algebraic or -> type
 546     maybe_tycon_app       = splitTyConApp_maybe first_inst_tau
 547     Just (tycon, arg_tys) = maybe_tycon_app
 548
 549         -- Stuff for an *algebraic* data type
 550     alg_tycon_app_maybe            = splitAlgTyConApp_maybe first_inst_tau
 551                                         -- The "Alg" part looks through synonyms
 552     is_alg_tycon_app               = maybeToBool alg_tycon_app_maybe
 553     Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
 554
 555     constructors_visible = not (null data_cons)
 556
 557
 558 -- These conditions come directly from what the DsCCall is capable of.
 559 -- Totally grotesque.  Green card should solve this.
 560
 561 ccallable_type   ty = isUnLiftedType ty ||                              -- Allow CCallable Int# etc
 562                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 563                       ty == stringTy ||
 564                       byte_arr_thing
 565   where
 566     byte_arr_thing = case splitAlgTyConApp_maybe ty of
 567                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 568                                 length data_con_arg_tys == 2 &&
 569                                 maybeToBool maybe_arg2_tycon &&
 570                                 (arg2_tycon == byteArrayPrimTyCon ||
 571                                  arg2_tycon == mutableByteArrayPrimTyCon)
 572                              where
 573                                 data_con_arg_tys = dataConArgTys data_con ty_args
 574                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 575                                 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
 576                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 577
 578                         other -> False
 579
 580 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 581                         -- Or, a data type with a single nullary constructor
 582                       case (splitAlgTyConApp_maybe ty) of
 583                         Just (tycon, tys_applied, [data_con])
 584                                 -> isNullaryDataCon data_con
 585                         other -> False
 586 \end{code}
 587
 588 \begin{code}
 589 instConstraintErr clas tys
 590   = hang (ptext SLIT("Illegal constaint") <+>
 591           quotes (pprConstraint clas tys) <+>
 592           ptext SLIT("in instance context"))
 593          4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
 594
 595 instTypeErr clas tys msg
 596   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 597          nest 4 (parens msg)
 598     ]
 599
 600 derivingWhenInstanceExistsErr clas tycon
 601   = hang (hsep [ptext SLIT("Deriving class"),
 602                        quotes (ppr clas),
 603                        ptext SLIT("type"), quotes (ppr tycon)])
 604          4 (ptext SLIT("when an explicit instance exists"))
 605
 606 nonBoxedPrimCCallErr clas inst_ty
 607   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 608          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 609                         ppr inst_ty])
 610
 611 {-
 612   Declaring CCallable & CReturnable instances in a module different
 613   from where the type was defined. Caused by importing data type
 614   abstractly (either programmatically or by the renamer being over-eager
 615   in its pruning.)
 616 -}
 617 invisibleDataConPrimCCallErr clas inst_ty
 618   = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
 619                 ptext SLIT("not visible when checking"),
 620                 quotes (ppr clas), ptext SLIT("instance")])
 621         4 (hsep [text "(Try either importing", ppr inst_ty,
 622                  text "non-abstractly or compile using -fno-prune-tydecls ..)"])
 623
 624 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 625 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
 626 \end{code}