import HsSyn
import HsTypes
-import BasicTypes
import HscTypes
import BuildTyCl
import TcUnify
import TcMType
import TcType
import TysWiredIn ( unitTy )
-import FunDeps
import Type
import Generics
import Class
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for a synonym
- unless (isSynTyCon family) $
- addErr (wrongKindOfFamily family)
+ checkTc (isOpenTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind
-- we need the exact same number of type parameters as the family
-- declaration
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
do { -- check that the family declaration is for the right kind
- unless (isAlgTyCon fam_tycon) $
- addErr (wrongKindOfFamily fam_tycon)
+ checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
; -- (1) kind check the data declaration as usual
; k_decl <- kcDataDecl decl k_tvs
-- foralls earlier)
; mapM_ checkTyFamFreeness t_typats
+ -- Check that we don't use GADT syntax in H98 world
+ ; gadt_ok <- doptM Opt_GADTs
+ ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
-- (b) a newtype has exactly one constructor
; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons)
-- type functions can have a higher-kinded result
; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckHsType hs_typats kinds
+ ; typats <- zipWithM kcCheckLHsType hs_typats kinds
; thing_inside tvs typats resultKind fam_tycon
}
where
kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
<+> brackets (ppr k_tvs))
- ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
+ ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
- kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
- kcHsTyVars ex_tvs $ \ex_tvs' -> do
- ex_ctxt' <- kcHsContext ex_ctxt
- details' <- kc_con_details details
- res' <- case res of
- ResTyH98 -> return ResTyH98
- ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
- return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
+ kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _)
+ = addErrCtxt (dataConCtxt name) $
+ kcHsTyVars ex_tvs $ \ex_tvs' -> do
+ do { ex_ctxt' <- kcHsContext ex_ctxt
+ ; details' <- kc_con_details details
+ ; res' <- case res of
+ ResTyH98 -> return ResTyH98
+ ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
+ ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
}
where
is_rec = calc_isrec tc_name
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
+ h98_syntax = consUseH98Syntax cons
tcTyClDecl1 calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
name = tyVarName tv
(env', occ') = tidyOccName env (getOccName name)
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _ = True
+ -- All constructors have same shape
+
-------------------
tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name
checkValidDataCon tc con
= setSrcSpan (srcLocSpan (getSrcLoc con)) $
addErrCtxt (dataConCtxt con) $
- do { let tc_tvs = tyConTyVars tc
+ do { traceTc (ptext (sLit "Validity of data con") <+> ppr con)
+ ; let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
actual_res_ty = dataConOrigResTy con
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
-- class Error e => Game b mv e | b -> mv e where
-- newBoard :: MonadState b m => m ()
-- Here, MonadState has a fundep m->b, so newBoard is fine
- ; let grown_tyvars = grow theta (mkVarSet tyvars)
+ ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
<+> ppr exp_arity
badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr =
- ptext (sLit "Illegal family instance in hs-boot file")
-
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family =
- ptext (sLit "Wrong category of family instance; declaration was for a") <+>
- kindOfFamily
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
where
kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
| isAlgTyCon family = ptext (sLit "data type")
projects / ghc-hetmet.git / blobdiff