RenamedSig, RenamedHsDecl
)
import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr,
- maybeBoxedPrimType, mkHsTyLam, mkHsTyApp,
- )
+ maybeBoxedPrimType
+ )
-import TcBinds ( tcPragmaSigs, sigThetaCtxt )
+import TcBinds ( tcPragmaSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
import RnMonad ( RnNameSupply )
import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE )
-import PragmaInfo ( PragmaInfo(..) )
+ newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon )
)
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
import Class ( classBigSig, Class )
-import Id ( idType, isNullaryDataCon, dataConArgTys, Id )
+import Id ( isNullaryDataCon, dataConArgTys, Id )
import Maybes ( maybeToBool, seqMaybe, catMaybes )
import Name ( nameOccName, mkLocalName,
isLocallyDefined, Module,
NamedThing(..)
)
import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
-import PprType ( pprParendGenType, pprConstraint )
+import PprType ( pprParendType, pprConstraint )
import SrcLoc ( SrcLoc, noSrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
import Type ( Type, ThetaType, isUnpointedType,
dfun_arg_dicts `plusLIE`
sc_dicts `plusLIE`
unionManyBags meth_lies
- in
- tcAddErrCtxt superClassCtxt $
- tcAddErrCtxtM (sigThetaCtxt sc_dicts) $
-
- -- Deal with the LIE arising from the method bindings
- tcSimplifyAndCheck (text "inst decl1a")
- inst_tyvars_set -- Local tyvars
- avail_insts
- (unionManyBags insts_needed_s) -- Need to get defns for all these
- `thenTc` \ (const_lie1, op_binds) ->
-
- -- Deal with the super-class bindings
- -- Ignore errors because they come from the *next* tcSimplify
- discardErrsTc (
- tcSimplifyAndCheck (text "inst decl1b")
- inst_tyvars_set
- dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
- -- get bound by just selecting from this_dict!!
- sc_dicts
- ) `thenTc` \ (const_lie2, sc_binds) ->
-
+ methods_lie = plusLIEs insts_needed_s
+ in
-- Check that we *could* construct the superclass dictionaries,
-- even though we are *actually* going to pass the superclass dicts in;
-- the check ensures that the caller will never have a problem building
-- them.
- tcSimplifyAndCheck (text "inst decl1c")
+ tcAddErrCtxt superClassCtxt (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
inst_tyvars_set -- Local tyvars
inst_decl_dicts -- The instance dictionaries available
sc_dicts -- The superclass dicationaries reqd
- `thenTc_`
- -- Ignore the result; we're only doing
+ ) `thenTc_`
+ -- Ignore the result; we're only doing
-- this to make sure it can be done.
+ -- Ditto method bindings
+ tcAddErrCtxt methodCtxt (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
+ inst_tyvars_set -- Local tyvars
+ avail_insts
+ methods_lie
+ ) `thenTc_`
+
+ -- Now do the simplification again, this time to get the
+ -- bindings; this time we use an enhanced "avails"
+ -- Ignore errors because they come from the *previous* tcSimplifys
+ discardErrsTc (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
+ inst_tyvars_set
+ dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
+ -- get bound by just selecting from this_dict!!
+ (sc_dicts `plusLIE` methods_lie)
+ ) `thenTc` \ (const_lie, lie_binds) ->
+
+
-- Create the result bindings
let
- const_lie = const_lie1 `plusLIE` const_lie2
- lie_binds = op_binds `AndMonoBinds` sc_binds
-
dict_constr = classDataCon clas
con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
(vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
if null simpl_theta then empty else ptext SLIT("=>"),
ppr clas,
- pprParendGenType inst_ty],
+ pprParendType inst_ty],
hsep [ptext SLIT(" derived from:"),
if null unspec_theta then empty else ppr unspec_theta,
if null unspec_theta then empty else ptext SLIT("=>"),
ppr clas,
- pprParendGenType unspec_inst_ty]])
+ pprParendType unspec_inst_ty]])
else id) (
returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
--
-- We flag this separately to give a more precise error msg.
--
- (uniqueOf clas == cCallableClassKey && not constructors_visible) ||
- (uniqueOf clas == cReturnableClassKey && not constructors_visible)
+ (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
+ && is_alg_tycon_app && not constructors_visible
= failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
| -- CCALL CHECK (b)
-- DERIVING CHECK
-- It is obviously illegal to have an explicit instance
-- for something that we are also planning to `derive'
- | clas `elem` (tyConDerivings inst_tycon)
+ | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
= failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-- Kind check will have ensured inst_taus is of length 1
- -- ALL TYPE VARIABLES => bad
- | all isTyVarTy inst_taus
- = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
-
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | not opt_GlasgowExts
+ | not opt_GlasgowExts
&& not (length inst_taus == 1 &&
- maybeToBool tyconapp_maybe &&
- not (isSynTyCon inst_tycon) &&
- all isTyVarTy arg_tys &&
+ maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
+ not (isSynTyCon tycon) && -- ...but not a synonym
+ all isTyVarTy arg_tys && -- Applied to type variables
length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
-- This last condition checks that all the type variables are distinct
)
= returnTc ()
where
- tyconapp_maybe = splitTyConApp_maybe first_inst_tau
- Just (inst_tycon, arg_tys) = tyconapp_maybe
(first_inst_tau : _) = inst_taus
- constructors_visible =
- case splitAlgTyConApp_maybe first_inst_tau of
- Just (_,_,[]) -> False
- everything_else -> True
+ -- Stuff for algebraic or -> type
+ maybe_tycon_app = splitTyConApp_maybe first_inst_tau
+ Just (tycon, arg_tys) = maybe_tycon_app
+
+ -- Stuff for an *algebraic* data type
+ alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
+ -- The "Alg" part looks through synonyms
+ is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
+ Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
+
+ constructors_visible = not (null data_cons)
+
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
nest 4 (parens msg)
]
-instBndrErr bndr clas
- = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)]
-
derivingWhenInstanceExistsErr clas tycon
= hang (hsep [ptext SLIT("Deriving class"),
quotes (ppr clas),
4 (hsep [text "(Try either importing", ppr inst_ty,
text "non-abstractly or compile using -fno-prune-tydecls ..)"])
-instMethodNotInClassErr occ clas
- = hang (ptext SLIT("Instance mentions a method not in the class"))
- 4 (hsep [ptext SLIT("class") <+> quotes (ppr clas),
- ptext SLIT("method") <+> quotes (ppr occ)])
-
-patMonoBindsCtxt pbind
- = hang (ptext SLIT("In a pattern binding:"))
- 4 (ppr pbind)
-
-methodSigCtxt name ty
- = hang (hsep [ptext SLIT("When matching the definition of class method"),
- quotes (ppr name), ptext SLIT("to its signature :") ])
- 4 (ppr ty)
-
-superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")
+methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}