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