ghc/compiler/typecheck/TcInstDcls.lhs

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