TcTyClsDecls: Typecheck type and class declarations
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
module TcTyClsDecls (
tcTyAndClassDecls, tcFamInstDecl
) where
; -- (1) kind check the right-hand side of the type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
+ -- we need the exact same number of type parameters as the family
+ -- declaration
+ ; let famArity = tyConArity family
+ ; checkTc (length k_typats == famArity) $
+ wrongNumberOfParmsErr famArity
+
-- (2) type check type equation
; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
; t_typats <- mappM tcHsKindedType k_typats
; t_rhs <- tcHsKindedType k_rhs
-- (3) check that
- -- - left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though)
- ; mappM_ checkTyFamFreeness t_typats
-
- -- - the right-hand side is a tau type
- ; unless (isTauTy t_rhs) $
- addErr (polyTyErr t_rhs)
+ -- - check the well-formedness of the instance
+ ; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
; rep_tc_name <- newFamInstTyConName tc_name loc
k_cons = tcdCons k_decl
-- result kind must be '*' (otherwise, we have too few patterns)
- ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name
+ ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity family)
-- (2) type check indexed data type declaration
; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
-- (3) Check that
-- - left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though)
+ -- (vanilla synonyms are fine, though, and we checked for
+ -- foralls earlier)
; mappM_ checkTyFamFreeness t_typats
-- - we don't use GADT syntax for indexed types
; tc_rhs <-
case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( isSingleton data_cons )
+ NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs rep_tc_name tycon (head data_cons)
; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
False h98_syntax (Just (family, t_typats))
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
other -> True
--- Check that a type index does not contain any type family applications
---
--- * Earlier phases have already checked that there are no foralls in the
--- type; we also cannot have PredTys and NoteTys are being skipped by using
--- the core view.
---
-checkTyFamFreeness :: Type -> TcM ()
-checkTyFamFreeness ty | Just (tycon, tys) <- splitTyConApp_maybe ty
- = if isSynTyCon tycon
- then addErr $ tyFamAppInIndexErr ty
- else mappM_ checkTyFamFreeness tys
- -- splitTyConApp_maybe uses the core view; hence,
- -- any synonym tycon must be a family tycon
-
- | Just (ty1, ty2) <- splitAppTy_maybe ty
- = checkTyFamFreeness ty1 >> checkTyFamFreeness ty2
-
- | otherwise -- only vars remaining
- = return ()
-
-
-- Kind checking of indexed types
-- -
else case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType ->
- ASSERT( isSingleton data_cons )
+ ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
(want_generic && canDoGenerics data_cons) h98_syntax Nothing
-- One argument
; checkTc (null eq_spec) (newtypePredError con)
-- Return type is (T a b c)
- ; checkTc (null ex_tvs && null theta) (newtypeExError con)
+ ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
-- No existentials
; checkTc (not (any isMarkedStrict (dataConStrictMarks con)))
(newtypeStrictError con)
-- No strictness
}
where
- (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
+ (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
-------------------------------
checkValidClass :: Class -> TcM ()
-- The 'tail' removes the initial (C a) from the
-- class itself, leaving just the method type
+ ; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau)
; checkValidType (FunSigCtxt op_name) tau
-- Check that the type mentions at least one of
= ptext SLIT("Family instance has too many parameters:") <+>
quotes (ppr tc_name)
-tooFewParmsErr tc_name
- = ptext SLIT("Family instance has too few parameters:") <+>
- quotes (ppr tc_name)
+tooFewParmsErr arity
+ = ptext SLIT("Family instance has too few parameters; expected") <+>
+ ppr arity
+
+wrongNumberOfParmsErr exp_arity
+ = ptext SLIT("Number of parameters must match family declaration; expected")
+ <+> ppr exp_arity
badBootFamInstDeclErr =
ptext SLIT("Illegal family instance in hs-boot file")
| isAlgTyCon family = ptext SLIT("data type")
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
-polyTyErr ty
- = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $
- ppr ty
-
-tyFamAppInIndexErr ty
- = hang (ptext SLIT("Illegal type family application in type instance") <>
- colon) 4 $
- ppr ty
-
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")]
projects / ghc-hetmet.git / blobdiff