import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), , NewOrData(..),
- tyClDeclTyVars, isSynDecl, LConDecl,
- LTyClDecl, tcdName, LHsTyVarBndr, LHsContext
+ tyClDeclTyVars, isSynDecl,
+ LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import HsTypes ( HsBang(..), getBangStrictness )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
-import HscTypes ( implicitTyThings )
+import HscTypes ( implicitTyThings, ModDetails )
import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
- tcExtendGlobalEnv, tcExtendKindEnv,
+ tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendRecEnv, tcLookupTyVar )
import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig )
import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
-import TcUnify ( unifyKind )
-import TcType ( TcKind, ThetaType, TcType, tyVarsOfType,
+import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy,
mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
tcSplitSigmaTy, tcEqType )
import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
+import Kind ( mkArrowKinds, splitKindFunTys )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
+tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
-> TcM TcGblEnv -- Input env extended by types and classes
-- and their implicit Ids,DataCons
-tcTyAndClassDecls boot_names decls
+tcTyAndClassDecls boot_details decls
= do { -- First check for cyclic type synonysm or classes
-- See notes with checkCycleErrs
checkCycleErrs decls
; mod <- getModule
- ; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names)
+ ; traceTc (text "tcTyAndCl" <+> ppr mod)
; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
do { let { -- Calculate variances and rec-flag
; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
- ; calc_rec = calcRecFlags boot_names rec_alg_tyclss
+ ; calc_rec = calcRecFlags boot_details rec_alg_tyclss
; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) }
-- Type-check the type synonyms, and extend the envt
; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
------------------------------------------------------------------------
getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
+-- Only for data type and class declarations
+-- Get as much info as possible from the data or class decl,
+-- so as to maximise usefulness of error messages
+getInitialKind (L _ decl)
+ = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
+ ; res_kind <- mk_res_kind decl
+ ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
+ where
+ mk_arg_kind (UserTyVar _) = newKindVar
+ mk_arg_kind (KindedTyVar _ kind) = return kind
+
+ mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
+ -- On GADT-style declarations we allow a kind signature
+ -- data T :: *->* where { ... }
+ mk_res_kind other = return liftedTypeKind
-getInitialKind decl
- = newKindVar `thenM` \ kind ->
- returnM (unLoc (tcdLName (unLoc decl)), kind)
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
= do { recSynErr decls; failM } -- Fail here to avoid error cascade
-- of out-of-scope tycons
+kindedTyVarKind (L _ (KindedTyVar _ k)) = k
+
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-- Not used for type synonyms (see kcSynDecl)
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
= kcTyClDeclBody decl $ \ tvs' ->
- do { ctxt' <- kcHsContext ctxt
+ do { is_boot <- tcIsHsBoot
+ ; checkTc (not is_boot) badBootClassDeclErr
+ ; ctxt' <- kcHsContext ctxt
; sigs' <- mappM (wrapLocM kc_sig) sigs
; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
where
kcTyClDeclBody :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> TcM a)
-> TcM a
- -- Extend the env with bindings for the tyvars, taken from
- -- the kind of the tycon/class. Give it to the thing inside, and
- -- check the result kind matches
+-- getInitialKind has made a suitably-shaped kind for the type or class
+-- Unpack it, and attribute those kinds to the type variables
+-- Extend the env with bindings for the tyvars, taken from
+-- the kind of the tycon/class. Give it to the thing inside, and
+ -- check the result kind matches
kcTyClDeclBody decl thing_inside
= tcAddDeclCtxt decl $
- kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs ->
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
- ; let tc_kind = case tc_ty_thing of { AThing k -> k }
- ;
- ; traceTc (text "kcbody" <+> ppr decl <+> ppr tc_kind <+> ppr (map kindedTyVarKind kinded_tvs) <+> ppr (result_kind decl))
- ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind)
- (result_kind decl)
- kinded_tvs)
- ; thing_inside kinded_tvs }
- where
- result_kind (TyData { tcdKindSig = Just kind }) = kind
- result_kind other = liftedTypeKind
- -- On GADT-style declarations we allow a kind signature
- -- data T :: *->* where { ... }
-
-kindedTyVarKind (L _ (KindedTyVar _ k)) = k
+ ; let tc_kind = case tc_ty_thing of { AThing k -> k }
+ (kinds, _) = splitKindFunTys tc_kind
+ hs_tvs = tcdTyVars decl
+ kinded_tvs = ASSERT( length kinds >= length hs_tvs )
+ [ L loc (KindedTyVar (hsTyVarName tv) k)
+ | (L loc tv, k) <- zip hs_tvs kinds]
+ ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
\end{code}
= tcTyVarBndrs tvs $ \ tvs' -> do
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
- ; stupid_theta <- tcStupidTheta ctxt cons
-
+ ; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; gla_exts <- doptM Opt_GlasgowExts
= AbstractTyCon -- "don't know"; hence Abstract
| otherwise
= case new_or_data of
- DataType -> mkDataTyConRhs stupid_theta data_cons
+ DataType -> mkDataTyConRhs data_cons
NewType -> ASSERT( isSingleton data_cons )
mkNewTyConRhs tycon (head data_cons)
- ; buildAlgTyCon tc_name final_tvs tc_rhs arg_vrcs is_rec
+ ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec
(want_generic && canDoGenerics data_cons)
})
; return (ATyCon tycon)
-- can complain if it's wrong.
-------------------
-tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType)
--- For GADTs we don't allow a context on the data declaration
--- whereas for standard Haskell style data declarations, we do
-tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _)
- = do { theta <- tcHsKindedContext ctxt; return (Just theta) }
-tcStupidTheta ctxt other -- Includes an empty constructor list
- = ASSERT( null (unLoc ctxt) ) return Nothing
-
--------------------
argStrictness :: Bool -- True <=> -funbox-strict_fields
-> TyCon -> [HsBang]
-> [TcType] -> [StrictnessMark]
; checkValidTheta (ClassSCCtxt (className cls)) theta
-- Check the class operations
- ; mappM_ check_op op_stuff
+ ; mappM_ (check_op gla_exts) op_stuff
-- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
- check_op (sel_id, dm)
+ check_op gla_exts (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta SigmaCtxt (tail theta)
-- The 'tail' removes the initial (C a) from the
where
op_name = idName sel_id
op_ty = idType sel_id
- (_,theta,tau) = tcSplitSigmaTy op_ty
-
+ (_,theta1,tau1) = tcSplitSigmaTy op_ty
+ (_,theta2,tau2) = tcSplitSigmaTy tau1
+ (theta,tau) | gla_exts = (theta1 ++ theta2, tau2)
+ | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
+ -- Ugh! The function might have a type like
+ -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
+ -- With -fglasgow-exts, we want to allow this, even though the inner
+ -- forall has an (Eq a) constraint. Whereas in general, each constraint
+ -- in the context of a for-all must mention at least one quantified
+ -- type variable. What a mess!
---------------------------------------------------------------------
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+
+badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file")
\end{code}
projects / ghc-hetmet.git / blobdiff