Commit 2767767f authored by simonpj's avatar simonpj
Browse files

[project @ 2001-08-14 06:35:56 by simonpj]

1. Arrange that w/w records unfoldings
   And that the simplifier preserves them

2. Greatly improve structure of checking user types in the typechecker
   Main changes:
	TcMType.checkValidType checks for a valid type
	TcMonoType.tcHsSigType uses checkValidType
	Type and class decls use TcMonoType.tcHsType (which does not
		check for validity) inside the knot in TcTyClsDecls,
		and then runs TcTyDecls.checkValidTyCon
		or TcClassDcl.checkValidClass to check for validity
		once the knot is tied
parent 76d4cbb3
......@@ -272,8 +272,9 @@ filterImports :: ModuleName -- The module being imported
-> WhereFrom -- Tells whether it's a {-# SOURCE #-} import
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
-> [AvailInfo] -- What's available
-> RnMG ([AvailInfo], -- What's actually imported
[AvailInfo], -- What's to be hidden
-> RnMG ([AvailInfo], -- "chosens"
[AvailInfo], -- "hides"
-- The true imports are "chosens" - "hides"
-- (It's convenient to return both the above sets, because
-- the substraction can be done more efficiently when
-- building the environment.)
......
......@@ -322,20 +322,13 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
rnHsType syn_doc ty `thenRn` \ ty' ->
returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
-- For H98 we do *not* universally quantify on the RHS of a synonym
-- Silently discard context... but the tyvars in the rest won't be in scope
-- In interface files all types are quantified, so this is a no-op
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExts ty = ty
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdSysNames = names, tcdLoc = src_loc})
......
......@@ -28,7 +28,7 @@ import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId
)
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, checkSigTyVars,
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
......@@ -736,7 +736,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
tcHsSigType poly_ty `thenTc` \ sig_ty ->
tcHsSigType (FunSigCtxt name) poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
......
......@@ -4,14 +4,14 @@
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
module TcClassDcl ( tcClassDecl1, tcClassDecls2,
module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2,
tcMethodBind, badMethodErr
) where
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
HsExpr(..), HsLit(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassOpSig, isPragSig,
getClassDeclSysNames, placeHolderType
......@@ -19,8 +19,7 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
import BasicTypes ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedSig,
maybeGenericMatch
RenamedSig, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds )
......@@ -31,21 +30,23 @@ import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
import TcMonoType ( tcHsType, tcHsTheta, checkSigTyVars, sigCtxt, mkTcSig )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcMType ( tcInstTyVars )
import TcType ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, tcIsTyVarTy, tcSplitTyConApp_maybe )
import TcMType ( tcInstTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
import TcType ( Type, mkSigmaTy, mkTyVarTys, mkPredTys, mkClassPred,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
)
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import Class ( classTyVars, classBigSig, classTyCon,
import Class ( classTyVars, classBigSig, classTyCon, className,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
import Id ( Id, idType, idName )
import Id ( idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import NameSet ( emptyNameSet )
import Outputable
import Var ( TyVar )
......@@ -99,21 +100,13 @@ Death to "ExpandingDicts".
\begin{code}
tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 is_rec rec_env
tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 rec_env
(ClassDecl {tcdCtxt = context, tcdName = class_name,
tcdTyVars = tyvar_names, tcdFDs = fundeps,
tcdSigs = class_sigs, tcdMeths = def_methods,
tcdSysNames = sys_names, tcdLoc = src_loc})
= -- CHECK ARITY 1 FOR HASKELL 1.4
doptsTc Opt_GlasgowExts `thenTc` \ gla_ext_opt ->
let
gla_exts = gla_ext_opt || not (maybeToBool def_methods)
-- Accept extensions if gla_exts is on,
-- or if we're looking at an interface file decl
in -- (in which case def_methods = Nothing
-- LOOK THINGS UP IN THE ENVIRONMENT
= -- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupClass class_name `thenTc` \ clas ->
let
tyvars = classTyVars clas
......@@ -123,31 +116,24 @@ tcClassDecl1 is_rec rec_env
in
tcExtendTyVarEnv tyvars $
-- SOURCE-CODE CONSISTENCY CHECKS
(case def_methods of
Nothing -> -- Not source
returnTc Nothing
Just dms -> -- Source so do error checks
checkTc (gla_exts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
checkDefaultBinds clas op_names dms `thenTc` \ dm_env ->
checkGenericClassIsUnary clas dm_env `thenTc_`
returnTc (Just dm_env)
) `thenTc` \ mb_dm_env ->
checkDefaultBinds clas op_names def_methods `thenTc` \ mb_dm_env ->
-- CHECK THE CONTEXT
tcSuperClasses is_rec gla_exts clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- Context is already kind-checked
ASSERT( length context == length sc_sel_names )
tcHsTheta context `thenTc` \ sc_theta ->
-- CHECK THE CLASS SIGNATURES,
mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
mapTc (tcClassSig rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
(op_tys, op_items) = unzip sig_stuff
sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
dict_con = mkDataCon datacon_name
[NotMarkedStrict | _ <- dict_component_tys]
......@@ -166,8 +152,8 @@ tcClassDecl1 is_rec rec_env
\end{code}
\begin{code}
checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
-> TcM (NameEnv Bool)
checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
-> TcM (Maybe (NameEnv Bool))
-- The returned environment says
-- x not in env => no default method
-- x -> True => generic default method
......@@ -180,74 +166,39 @@ checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
-- But do all this only for source binds
checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
checkDefaultBinds clas ops Nothing
= returnTc Nothing
checkDefaultBinds clas ops (Just mbs)
= go mbs `thenTc` \ dm_env ->
returnTc (Just dm_env)
where
go EmptyMonoBinds = returnTc emptyNameEnv
checkDefaultBinds clas ops (AndMonoBinds b1 b2)
= checkDefaultBinds clas ops b1 `thenTc` \ dm_info1 ->
checkDefaultBinds clas ops b2 `thenTc` \ dm_info2 ->
returnTc (dm_info1 `plusNameEnv` dm_info2)
go (AndMonoBinds b1 b2)
= go b1 `thenTc` \ dm_info1 ->
go b2 `thenTc` \ dm_info2 ->
returnTc (dm_info1 `plusNameEnv` dm_info2)
checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
= tcAddSrcLoc loc $
go (FunMonoBind op _ matches loc)
= tcAddSrcLoc loc $
-- Check that the op is from this class
checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
-- Check that all the defns ar generic, or none are
checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
returnTc (unitNameEnv op all_generic)
where
n_generic = count (maybeToBool . maybeGenericMatch) matches
none_generic = n_generic == 0
all_generic = n_generic == length matches
checkGenericClassIsUnary clas dm_env
= -- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
-- multi-parameter type classes!
checkTc (unary || no_generics) (genericMultiParamErr clas)
where
unary = length (classTyVars clas) == 1
no_generics = not (or (nameEnvElts dm_env))
returnTc (unitNameEnv op all_generic)
where
n_generic = count (maybeToBool . maybeGenericMatch) matches
none_generic = n_generic == 0
all_generic = n_generic == length matches
\end{code}
\begin{code}
tcSuperClasses :: RecFlag -> Bool -> Class
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
-> TcM (ThetaType, -- the superclass context
[Id]) -- superclass selector Ids
tcSuperClasses is_rec gla_exts clas context sc_sel_names
= ASSERT( length context == length sc_sel_names )
-- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- For std Haskell check that the context constrains only tyvars
mapTc_ check_constraint context `thenTc_`
-- Context is already kind-checked
tcRecTheta is_rec context `thenTc` \ sc_theta ->
let
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
in
-- Done
returnTc (sc_theta, sc_sel_ids)
where
check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
ok (HsClassP c tys) | gla_exts = True
| otherwise = all is_tyvar tys
ok (HsIParam _ _) = False -- Never legal
is_tyvar (HsTyVar _) = True
is_tyvar other = False
tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only!
tcClassSig :: RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> Maybe (NameEnv Bool) -- Info about default methods
......@@ -260,20 +211,17 @@ tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only!
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
tcClassSig unf_env clas clas_tyvars maybe_dm_env
(ClassOpSig op_name sig_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
tcHsType op_ty `thenTc` \ local_ty ->
tcHsRecType is_rec op_ty `thenTc` \ local_ty ->
-- Check for ambiguous class op types
let
theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
in
checkAmbiguity is_rec True clas_tyvars theta local_ty `thenTc` \ global_ty ->
global_ty = mkSigmaTy clas_tyvars theta local_ty
-- The default method's type should really come from the
-- iface file, since it could be usage-generalised, but this
-- requires altering the mess of knots in TcModule and I'm
......@@ -281,7 +229,6 @@ tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
-- of types of default methods (and dict funs) by annotating them
-- TyGenNever (in MkId). Ugh! KSW 1999-09.
let
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
dm_id = mkDefaultMethodId dm_name global_ty
......@@ -301,14 +248,55 @@ tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
Just True -> GenDefMeth
Just False -> DefMeth dm_id
in
-- Check that for a generic method, the type of
-- the method is sufficiently simple
checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty)
(badGenericMethodType op_name op_ty) `thenTc_`
returnTc (local_ty, (sel_id, dm_info))
\end{code}
checkValidClass is called once the mutually-recursive knot has been
tied, so we can look at things freely.
\begin{code}
checkValidClass :: Class -> TcM ()
checkValidClass cls
= -- CHECK ARITY 1 FOR HASKELL 1.4
doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
-- Check that the class is unary, unless GlaExs
checkTc (gla_exts || unary)
(classArityErr cls) `thenTc_`
-- Check the super-classes
checkValidTheta (ClassSCCtxt (className cls)) theta `thenTc_`
-- Check the class operations
mapTc_ check_op op_stuff `thenTc_`
-- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
-- multi-parameter type classes!
checkTc (unary || no_generics) (genericMultiParamErr cls)
where
(tyvars, theta, sel_ids, op_stuff) = classBigSig cls
unary = length tyvars == 1
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
check_op (sel_id, dm)
= checkValidTheta SigmaCtxt (tail theta) `thenTc_`
-- The 'tail' removes the initial (C a) from the
-- class itself, leaving just the method type
checkValidType (FunSigCtxt op_name) tau `thenTc_`
-- Check that for a generic method, the type of
-- the method is sufficiently simple
checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
(badGenericMethodType op_name op_ty)
where
op_name = idName sel_id
op_ty = idType sel_id
(_,theta,tau) = tcSplitSigmaTy op_ty
\end{code}
%************************************************************************
%* *
......@@ -524,7 +512,7 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
tcExtendGlobalTyVars (mkVarSet inst_tyvars)
(tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel meth_bind
[sig_info] meth_prags NonRecursive
[sig_info] meth_prags NonRecursive
) `thenTc` \ (binds, insts, _) ->
tcExtendLocalValEnv [(meth_name, meth_id)]
......@@ -626,12 +614,8 @@ find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
Contexts and errors
~~~~~~~~~~~~~~~~~~~
\begin{code}
classArityErr class_name
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
superClassErr clas sc
= ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr clas)
classArityErr cls
= ptext SLIT("Too many parameters for class") <+> quotes (ppr cls)
defltMethCtxt clas
= ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
......
......@@ -28,7 +28,7 @@ import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon, simpleHsLitTy )
import TcSimplify ( tcSimplifyCheck, tcSimplifyIPs )
import TcMType ( tcInstTyVars, tcInstType,
......@@ -56,7 +56,7 @@ import VarSet ( elemVarSet )
import TysWiredIn ( boolTy, mkListTy, listTyCon )
import PrelNames ( cCallableClassName,
cReturnableClassName,
enumFromName, enumFromThenName, negateName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
thenMName, failMName, returnMName, ioTyConName
)
......@@ -593,9 +593,9 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcAddErrCtxt (exprSigCtxt in_expr) $
tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
= tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
tcAddErrCtxt (exprSigCtxt in_expr) $
if not (isQualifiedTy sig_tc_ty) then
-- Easy case
unifyTauTy sig_tc_ty res_ty `thenTc_`
......
......@@ -26,9 +26,8 @@ import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
import TcMonoType ( tcHsLiftedSigType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
import TcExpr ( tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
......@@ -76,7 +75,7 @@ tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
......@@ -162,8 +161,8 @@ tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
tcCheckFEType sig_ty spec `thenTc_`
......
......@@ -23,10 +23,10 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
import TcMType ( tcInstType, tcInstTyVars )
import TcMType ( tcInstTyVars, checkValidTheta, UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
isTyVarClassPred, inheritablePred
tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys_maybe
)
import Inst ( InstOrigin(..),
newDicts, instToId,
......@@ -40,7 +40,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcHsTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType, checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
......@@ -59,7 +59,7 @@ import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
import NameSet ( unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import PprType ( pprClassPred )
import TyCon ( TyCon, isSynTyCon )
import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
......@@ -240,21 +240,26 @@ addInstDFuns inst_env dfuns
\begin{code}
tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
-- Type-check all the stuff before the "where"
tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
tcAddErrCtxt (instDeclCtxt poly_ty) $
-- Type-check all the stuff before the "where"
traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_`
tcAddErrCtxt (instDeclCtxt poly_ty) (
tcHsSigType poly_ty
) `thenTc` \ poly_ty' ->
-- Typecheck the instance type itself. We can't use
-- tcHsSigType, because it's not a valid user type.
kcHsSigType poly_ty `thenTc_`
tcHsType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty'
(tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
maybe_cls_tys = case tcSplitPredTy_maybe tau of
Just pred -> getClassPredTys_maybe pred
Nothing -> Nothing
Just (clas, inst_tys) = maybe_cls_tys
in
checkTc (maybeToBool maybe_cls_tys) (instHeadErr tau) `thenTc_`
traceTc (text "Check validity") `thenTc_`
(case maybe_dfun_name of
Nothing -> -- A source-file instance declaration
......@@ -264,24 +269,18 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
-- contain something illegal in normal Haskell, notably
-- instance CCallable [Char]
getDOptsTc `thenTc` \ dflags ->
checkInstValidity dflags theta clas inst_tys `thenTc_`
-- Make the dfun id and return it
traceTc (text "new name") `thenTc_`
newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
returnNF_Tc (True, dfun_name)
checkValidTheta InstDeclCtxt theta `thenTc_`
checkValidInstHead dflags theta clas inst_tys `thenTc_`
newDFunName clas inst_tys src_loc
Just dfun_name -> -- An interface-file instance declaration
-- Make the dfun id
returnNF_Tc (False, dfun_name)
) `thenNF_Tc` \ (is_local, dfun_name) ->
returnNF_Tc dfun_name
) `thenNF_Tc` \ dfun_name ->
traceTc (text "Name" <+> ppr dfun_name) `thenTc_`
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
returnTc [InstInfo { iDFunId = dfun_id,
iBinds = binds, iPrags = uprags }]
returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }]
\end{code}
......@@ -411,7 +410,7 @@ mkGenericInstance clas loc (hs_ty, binds)
tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars ->
-- Type-check the instance type, and check its form
tcHsSigType hs_ty `thenTc` \ inst_ty ->
tcHsSigType GenPatCtxt hs_ty `thenTc` \ inst_ty ->
checkTc (validGenericInstanceType inst_ty)
(badGenericInstanceType binds) `thenTc_`
......@@ -759,7 +758,7 @@ simplified: only zeze2 is extracted and its body is simplified.
%* *
%************************************************************************
@scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
it must normally look like: @instance Foo (Tycon a b c ...) ...@
The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
......@@ -769,26 +768,13 @@ compiled elsewhere). In these cases, we let them go through anyway.
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
checkInstValidity dflags theta clas inst_tys
checkValidInstHead dflags theta clas inst_tys
| null errs = returnTc ()
| otherwise = addErrsTc errs `thenNF_Tc_` failTc
where
errs = checkInstHead dflags theta clas inst_tys ++
[err | pred <- theta, err <- checkInstConstraint dflags pred]
checkInstConstraint dflags pred
-- Checks whether a predicate is legal in the
-- context of an instance declaration
| ok = []
| otherwise = [instConstraintErr pred]
where
ok = inheritablePred pred &&
(isTyVarClassPred pred || arbitrary_preds_ok)
arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
errs = check_inst_head dflags theta clas inst_tys
checkInstHead dflags theta clas inst_taus
check_inst_head dflags theta clas inst_taus
| -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
......@@ -879,12 +865,6 @@ instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes
\end{code}
\begin{code}
instConstraintErr pred
= hang (ptext SLIT("Illegal constraint") <+>
quotes (pprPred pred) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
badGenericInstanceType binds
= vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
nest 4 (ppr binds)]
......@@ -902,6 +882,10 @@ dupGenericInsts tc_inst_infos
where
ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
instHeadErr ty
= vcat [ptext SLIT("Illegal instance head:") <+> ppr ty,
ptext SLIT("Instance head must be of form <context> => <class> <types>")]
instTypeErr clas tys msg
= sep [ptext SLIT("Illegal instance declaration for") <+>
quotes (pprClassPred clas tys),
......
......@@ -22,6 +22,11 @@ module TcMType (
tcInstSigVars, tcInstType,
tcSplitRhoTyM,
--------------------------------
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
SourceTyCtxt(..), checkValidTheta,
--------------------------------
-- Unification
unifyTauTy, unifyTauTyList, unifyTauTyLists,
......@@ -40,23 +45,27 @@ module TcMType (
-- friends:
import TypeRep ( Type(..), SourceType(..), Kind, TyNote(..), -- friend
import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation