Commit 3cd1360f authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Refactor checking for GADT-like datacons' return types

This check is somewhat subtle. See Note [Checking GADT return types]
in TcTyClsDecls. The new plan is to check *before* desugaring the type
from HsType to Type. This avoids problems with the pattern-match
in rejigConRes.

As a nice side benefit to this, I discovered that Template Haskell
splices were a little conservative in their treatment of valid data
constructors. (For example, a kind signature in the return type caused
failure.) Now, the TH code uses exactly the same function as the
"real" code, which is nice. See hsTyGetAppHead_maybe in HsTypes.
parent e8aa8ccb
......@@ -529,8 +529,7 @@ mkGadtCtxt :: [Name] -- Tyvars of the data type
mkGadtCtxt _ ResTyH98
= return ([], [])
mkGadtCtxt data_tvs (ResTyGADT res_ty)
| let (head_ty, tys) = splitHsAppTys res_ty []
, Just _ <- is_hs_tyvar head_ty
| Just (_, tys) <- hsTyGetAppHead_maybe res_ty
, data_tvs `equalLength` tys
= return (go [] [] (data_tvs `zip` tys))
......
......@@ -32,7 +32,7 @@ module HsTypes (
splitLHsInstDeclTy_maybe,
splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType,
splitHsAppTys, mkHsAppTys, mkHsOpTy,
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
......@@ -448,6 +448,20 @@ splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
splitHsAppTys f as = (f,as)
-- retrieve the name of the "head" of a nested type application
-- somewhat like splitHsAppTys, but a little more thorough
-- used to examine the result of a GADT-like datacon, so it doesn't handle
-- *all* cases (like lists, tuples, (~), etc.)
hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n])
hsTyGetAppHead_maybe = go []
where
go tys (L _ (HsTyVar n)) = Just (n, tys)
go tys (L _ (HsAppTy l r)) = go (r : tys) l
go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys)
go tys (L _ (HsParTy t)) = go tys t
go tys (L _ (HsKindSig t _)) = go tys t
go _ _ = Nothing
mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
mkHsAppTys fun_ty (arg_ty:arg_tys)
......
......@@ -662,7 +662,8 @@ tcDataFamInstDecl mb_clsinfo
; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns
; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats (kcDataDefn defn) $
; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats
(kcDataDefn (unLoc fam_tc_name) defn) $
\tvs' pats' res_kind -> do
{ -- Check that left-hand side contains no type family applications
......@@ -684,7 +685,7 @@ tcDataFamInstDecl mb_clsinfo
; let orig_res_ty = mkTyConApp fam_tc pats'
; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcConDecls new_or_data rec_rep_tc
do { data_cons <- tcConDecls new_or_data (unLoc fam_tc_name) rec_rep_tc
(tvs', orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
......@@ -710,7 +711,6 @@ tcDataFamInstDecl mb_clsinfo
-- Remember to check validity; no recursion to worry about here
; let role_annots = unitNameEnv rep_tc_name (repeat Nothing)
; checkValidTyConDataConsOnly rep_tc
; checkValidTyCon rep_tc role_annots
; return fam_inst } }
where
......
This diff is collapsed.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment