Commit 2d4db40a authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #10815 by kind-checking type patterns against known kinds.

tcFamTyPats now must take information about the instantiation of any
class variables, when checking the instance of an associated type.

Getting this to work out required some unexpected refactoring in
TcDeriv. TcDeriv needs to look at class instances because of the
possibility of associated datatypes with `deriving` specs. TcDeriv
worked over the user-specified instances. But any data family instances
were already processed, and TcDeriv had no way of finding the rep
tycons. Indeed, TcDeriv *re-type-checked* any data family instances
in an attempt to rediscover what GHC already knew. So, this commit
introduces better tracking of compiled data families between TcInstDcls
and TcDeriv to streamline all of this.
parent a8406f81
...@@ -8,7 +8,7 @@ Handles @deriving@ clauses on @data@ declarations. ...@@ -8,7 +8,7 @@ Handles @deriving@ clauses on @data@ declarations.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module TcDeriv ( tcDeriving ) where module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -19,9 +19,8 @@ import TcRnMonad ...@@ -19,9 +19,8 @@ import TcRnMonad
import FamInst import FamInst
import TcErrors( reportAllUnsolved ) import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred ) import TcValidity( validDerivPred )
import TcClassDcl( tcMkDeclCtxt )
import TcEnv import TcEnv
import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn )
import TcClassDcl( tcAddDeclCtxt ) -- Small helper
import TcGenDeriv -- Deriv stuff import TcGenDeriv -- Deriv stuff
import TcGenGenerics import TcGenGenerics
import InstEnv import InstEnv
...@@ -331,6 +330,33 @@ See Trac #3221. Consider ...@@ -331,6 +330,33 @@ See Trac #3221. Consider
Are T1 and T2 unused? Well, no: the deriving clause expands to mention Are T1 and T2 unused? Well, no: the deriving clause expands to mention
both of them. So we gather defs/uses from deriving just like anything else. both of them. So we gather defs/uses from deriving just like anything else.
-}
-- | Stuff needed to process a `deriving` clause
data DerivInfo = DerivInfo { di_rep_tc :: TyCon
-- ^ The data tycon for normal datatypes,
-- or the *representation* tycon for data families
, di_preds :: [LHsType Name]
, di_ctxt :: SDoc -- ^ error context
}
-- | Extract `deriving` clauses of proper data type (skips data families)
mkDerivInfos :: [TyClGroup Name] -> TcM [DerivInfo]
mkDerivInfos tycls = concatMapM mk_derivs tycls
where
mk_derivs (TyClGroup { group_tyclds = decls })
= concatMapM (mk_deriv . unLoc) decls
mk_deriv decl@(DataDecl { tcdLName = L _ data_name
, tcdDataDefn =
HsDataDefn { dd_derivs = Just (L _ preds) } })
= do { tycon <- tcLookupTyCon data_name
; return [DerivInfo { di_rep_tc = tycon, di_preds = preds
, di_ctxt = tcMkDeclCtxt decl }] }
mk_deriv _ = return []
{-
************************************************************************ ************************************************************************
* * * *
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
...@@ -338,11 +364,10 @@ both of them. So we gather defs/uses from deriving just like anything else. ...@@ -338,11 +364,10 @@ both of them. So we gather defs/uses from deriving just like anything else.
************************************************************************ ************************************************************************
-} -}
tcDeriving :: [LTyClDecl Name] -- All type constructors tcDeriving :: [DerivInfo] -- All `deriving` clauses
-> [LInstDecl Name] -- All instance declarations
-> [LDerivDecl Name] -- All stand-alone deriving declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name) -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
tcDeriving tycl_decls inst_decls deriv_decls tcDeriving deriv_infos deriv_decls
= recoverM (do { g <- getGblEnv = recoverM (do { g <- getGblEnv
; return (g, emptyBag, emptyValBindsOut)}) $ ; return (g, emptyBag, emptyValBindsOut)}) $
do { -- Fish the "deriving"-related information out of the TcEnv do { -- Fish the "deriving"-related information out of the TcEnv
...@@ -350,7 +375,7 @@ tcDeriving tycl_decls inst_decls deriv_decls ...@@ -350,7 +375,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
is_boot <- tcIsHsBootOrSig is_boot <- tcIsHsBootOrSig
; traceTc "tcDeriving" (ppr is_boot) ; traceTc "tcDeriving" (ppr is_boot)
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
; traceTc "tcDeriving 1" (ppr early_specs) ; traceTc "tcDeriving 1" (ppr early_specs)
-- for each type, determine the auxliary declarations that are common -- for each type, determine the auxliary declarations that are common
...@@ -501,6 +526,20 @@ So we want to signal a user of the data constructor 'MkP'. ...@@ -501,6 +526,20 @@ So we want to signal a user of the data constructor 'MkP'.
This is the reason behind the (Maybe Name) part of the return type This is the reason behind the (Maybe Name) part of the return type
of genInst. of genInst.
Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
the rep_tc by means of a lookup. And yet we have the rep_tc right here!
Why look it up again? Answer: it's just easier this way.
We drop some number of arguments from the end of the datatype definition
in deriveTyData. The arguments are dropped from the fam_tc.
This action may drop a *different* number of arguments
passed to the rep_tc, depending on how many free variables, etc., the
dropped patterns have.
Also, this technique carries over the kind substitution from deriveTyData
nicely.
************************************************************************ ************************************************************************
* * * *
From HsSyn to DerivSpec From HsSyn to DerivSpec
...@@ -511,15 +550,13 @@ of genInst. ...@@ -511,15 +550,13 @@ of genInst.
-} -}
makeDerivSpecs :: Bool makeDerivSpecs :: Bool
-> [LTyClDecl Name] -> [DerivInfo]
-> [LInstDecl Name]
-> [LDerivDecl Name] -> [LDerivDecl Name]
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls makeDerivSpecs is_boot deriv_infos deriv_decls
= do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls = do { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo) deriv_infos
; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls ; let eqns = eqns1 ++ eqns2
; let eqns = eqns1 ++ eqns2 ++ eqns3
; if is_boot then -- No 'deriving' at all in hs-boot files ; if is_boot then -- No 'deriving' at all in hs-boot files
do { unless (null eqns) (add_deriv_err (head eqns)) do { unless (null eqns) (add_deriv_err (head eqns))
...@@ -532,63 +569,21 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ...@@ -532,63 +569,21 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
2 (ptext (sLit "Use an instance declaration instead"))) 2 (ptext (sLit "Use an instance declaration instead")))
------------------------------------------------------------------ ------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] -- | Process a `deriving` clause
deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
, tcdDataDefn = HsDataDefn { dd_derivs = preds } })) deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
= tcAddDeclCtxt decl $ , di_ctxt = err_ctxt })
do { tc <- tcLookupTyCon tc_name = addErrCtxt err_ctxt $
; let tvs = tyConTyVars tc concatMapM (deriveTyData tvs tc tys) preds
tys = mkTyVarTys tvs where
tvs = tyConTyVars rep_tc
; case preds of (tc, tys) = case tyConFamInstSig_maybe rep_tc of
Just (L _ preds') -> concatMapM (deriveTyData tvs tc tys) preds' -- data family:
Nothing -> return [] } Just (fam_tc, pats, _) -> (fam_tc, pats)
-- NB: deriveTyData wants the *user-specified*
deriveTyDecl _ = return [] -- name. See Note [Why we don't pass rep_tc into deriveTyData]
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
deriveInstDecl (L _ (TyFamInstD {})) = return []
deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
= deriveFamInst fam_inst
deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
= concatMapM (deriveFamInst . unLoc) fam_insts
------------------------------------------------------------------
deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
deriveFamInst decl@(DataFamInstDecl
{ dfid_tycon = L _ tc_name, dfid_pats = pats
, dfid_defn
= defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
= tcAddDataFamInstCtxt decl $
do { fam_tc <- tcLookupTyCon tc_name
; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
-- kcDataDefn defn: see Note [Finding the LHS patterns]
\ tvs' pats' _ ->
concatMapM (deriveTyData tvs' fam_tc pats') preds }
deriveFamInst _ = return []
{- _ -> (rep_tc, mkTyVarTys tvs) -- datatype
Note [Finding the LHS patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When kind polymorphism is in play, we need to be careful. Here is
Trac #9359:
data Cmp a where
Sup :: Cmp a
V :: a -> Cmp a
data family CmpInterval (a :: Cmp k) (b :: Cmp k) :: *
data instance CmpInterval (V c) Sup = Starting c deriving( Show )
So CmpInterval is kind-polymorphic, but the data instance is not
CmpInterval :: forall k. Cmp k -> Cmp k -> *
data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show )
Hence, when deriving the type patterns in deriveFamInst, we must kind
check the RHS (the data constructor 'Starting c') as well as the LHS,
so that we correctly see the instantiation to *.
-}
------------------------------------------------------------------ ------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
...@@ -669,8 +664,8 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) ...@@ -669,8 +664,8 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
let (arg_kinds, _) = splitKindFunTys cls_arg_kind let (arg_kinds, _) = splitKindFunTys cls_arg_kind
n_args_to_drop = length arg_kinds n_args_to_drop = length arg_kinds
n_args_to_keep = tyConArity tc - n_args_to_drop n_args_to_keep = tyConArity tc - n_args_to_drop
args_to_drop = drop n_args_to_keep tc_args (tc_args_to_keep, args_to_drop)
tc_args_to_keep = take n_args_to_keep tc_args = splitAt n_args_to_keep tc_args
inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep)
dropped_tvs = tyVarsOfTypes args_to_drop dropped_tvs = tyVarsOfTypes args_to_drop
......
...@@ -61,7 +61,7 @@ import Util ...@@ -61,7 +61,7 @@ import Util
import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
import Control.Monad import Control.Monad
import Maybes ( isNothing, isJust, whenIsJust, catMaybes ) import Maybes
import Data.List ( mapAccumL, partition ) import Data.List ( mapAccumL, partition )
{- {-
...@@ -357,7 +357,7 @@ Gather up the instance declarations from their various sources ...@@ -357,7 +357,7 @@ Gather up the instance declarations from their various sources
-} -}
tcInstDecls1 -- Deal with both source-code and imported instance decls tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LTyClDecl Name] -- For deriving stuff :: [TyClGroup Name] -- For deriving stuff
-> [LInstDecl Name] -- Source code instance decls -> [LInstDecl Name] -- Source code instance decls
-> [LDerivDecl Name] -- Source code stand-alone deriving decls -> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env -> TcM (TcGblEnv, -- The full inst env
...@@ -373,7 +373,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ...@@ -373,7 +373,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- Do class and family instance declarations -- Do class and family instance declarations
; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
; let (local_infos_s, fam_insts_s) = unzip stuff ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
fam_insts = concat fam_insts_s fam_insts = concat fam_insts_s
local_infos' = concat local_infos_s local_infos' = concat local_infos_s
-- Handwritten instances of the poly-kinded Typeable class are -- Handwritten instances of the poly-kinded Typeable class are
...@@ -398,7 +398,10 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ...@@ -398,7 +398,10 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
<- if isBrackStage th_stage <- if isBrackStage th_stage
then do { gbl_env <- getGblEnv then do { gbl_env <- getGblEnv
; return (gbl_env, emptyBag, emptyValBindsOut) } ; return (gbl_env, emptyBag, emptyValBindsOut) }
else tcDeriving tycl_decls inst_decls deriv_decls else do { data_deriv_infos <- mkDerivInfos tycl_decls
; let deriv_infos = concat datafam_deriv_infos ++
data_deriv_infos
; tcDeriving deriv_infos deriv_decls }
-- Fail if there are any handwritten instance of poly-kinded Typeable -- Fail if there are any handwritten instance of poly-kinded Typeable
; mapM_ typeable_err typeable_instances ; mapM_ typeable_err typeable_instances
...@@ -418,7 +421,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ...@@ -418,7 +421,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; return ( gbl_env ; return ( gbl_env
, bagToList deriv_inst_info ++ local_infos , bagToList deriv_inst_info ++ local_infos
, deriv_binds) , deriv_binds )
}} }}
where where
-- Separate the Typeable instances from the rest -- Separate the Typeable instances from the rest
...@@ -485,24 +488,26 @@ the brutal solution will do. ...@@ -485,24 +488,26 @@ the brutal solution will do.
-} -}
tcLocalInstDecl :: LInstDecl Name tcLocalInstDecl :: LInstDecl Name
-> TcM ([InstInfo Name], [FamInst]) -> TcM ([InstInfo Name], [FamInst], [DerivInfo])
-- A source-file instance declaration -- A source-file instance declaration
-- Type-check all the stuff before the "where" -- Type-check all the stuff before the "where"
-- --
-- We check for respectable instance type, and context -- We check for respectable instance type, and context
tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
= do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl) = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
; return ([], [fam_inst]) } ; return ([], [fam_inst], []) }
tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
= do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl) = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl)
; return ([], [fam_inst]) } ; return ([], [fam_inst], maybeToList m_deriv_info) }
tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
= do { (insts, fam_insts) <- tcClsInstDecl (L loc decl) = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
; return (insts, fam_insts) } ; return (insts, fam_insts, deriv_infos) }
tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) tcClsInstDecl :: LClsInstDecl Name
-> TcM ([InstInfo Name], [FamInst], [DerivInfo])
-- the returned DerivInfos are for any associated data families
tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats , cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = overlap_mode , cid_overlap_mode = overlap_mode
...@@ -522,8 +527,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ...@@ -522,8 +527,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; traceTc "tcLocalInstDecl" (ppr poly_ty) ; traceTc "tcLocalInstDecl" (ppr poly_ty)
; tyfam_insts0 <- tcExtendTyVarEnv tyvars $ ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
mapAndRecoverM (tcTyFamInstDecl mb_info) ats mapAndRecoverM (tcTyFamInstDecl mb_info) ats
; datafam_insts <- tcExtendTyVarEnv tyvars $ ; datafam_stuff <- tcExtendTyVarEnv tyvars $
mapAndRecoverM (tcDataFamInstDecl mb_info) adts mapAndRecoverM (tcDataFamInstDecl mb_info) adts
; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff
deriv_infos = catMaybes m_deriv_infos
-- Check for missing associated types and build them -- Check for missing associated types and build them
-- from their defaults (if available) -- from their defaults (if available)
...@@ -548,7 +555,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ...@@ -548,7 +555,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, ib_extensions = [] , ib_extensions = []
, ib_derived = False } } , ib_derived = False } }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
, deriv_infos ) }
tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
...@@ -604,7 +612,7 @@ lot of kinding and type checking code with ordinary algebraic data types (and ...@@ -604,7 +612,7 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs). GADTs).
-} -}
tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable tcFamInstDeclCombined :: Maybe ClsInfo
-> Located Name -> TcM TyCon -> Located Name -> TcM TyCon
tcFamInstDeclCombined mb_clsinfo fam_tc_lname tcFamInstDeclCombined mb_clsinfo fam_tc_lname
= do { -- Type family instances require -XTypeFamilies = do { -- Type family instances require -XTypeFamilies
...@@ -624,7 +632,7 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname ...@@ -624,7 +632,7 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname
; return fam_tc } ; return fam_tc }
tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable tcTyFamInstDecl :: Maybe ClsInfo
-> LTyFamInstDecl Name -> TcM FamInst -> LTyFamInstDecl Name -> TcM FamInst
-- "type instance" -- "type instance"
tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
...@@ -639,7 +647,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ...@@ -639,7 +647,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group -- (1) do the work of verifying the synonym group
; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn
-- (2) check for validity -- (2) check for validity
; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
...@@ -650,15 +658,16 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ...@@ -650,15 +658,16 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
; newFamInst SynFamilyInst axiom } ; newFamInst SynFamilyInst axiom }
tcDataFamInstDecl :: Maybe (Class, VarEnv Type) tcDataFamInstDecl :: Maybe ClsInfo
-> LDataFamInstDecl Name -> TcM FamInst -> LDataFamInstDecl Name -> TcM (FamInst, Maybe DerivInfo)
-- "newtype instance" and "data instance" -- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl (L loc decl@(DataFamInstDecl
{ dfid_pats = pats { dfid_pats = pats
, dfid_tycon = fam_tc_name , dfid_tycon = fam_tc_name
, dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_cons = cons } })) , dd_ctxt = ctxt, dd_cons = cons
, dd_derivs = derivs } }))
= setSrcSpan loc $ = setSrcSpan loc $
tcAddDataFamInstCtxt decl $ tcAddDataFamInstCtxt decl $
do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
...@@ -668,7 +677,7 @@ tcDataFamInstDecl mb_clsinfo ...@@ -668,7 +677,7 @@ tcDataFamInstDecl mb_clsinfo
; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns -- Kind check type patterns
; tcFamTyPats (famTyConShape fam_tc) pats ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
(kcDataDefn defn) $ (kcDataDefn defn) $
\tvs' pats' res_kind -> do \tvs' pats' res_kind -> do
...@@ -704,6 +713,9 @@ tcDataFamInstDecl mb_clsinfo ...@@ -704,6 +713,9 @@ tcDataFamInstDecl mb_clsinfo
(mkTyConApp rep_tc (mkTyVarTys eta_tvs)) (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = FamInstTyCon axiom fam_tc pats' parent = FamInstTyCon axiom fam_tc pats'
roles = map (const Nominal) tvs' roles = map (const Nominal) tvs'
-- NB: Use the tvs' from the pats. See bullet toward
-- the end of Note [Data type families] in TyCon
rep_tc = buildAlgTyCon rep_tc_name tvs' roles rep_tc = buildAlgTyCon rep_tc_name tvs' roles
(fmap unLoc cType) stupid_theta (fmap unLoc cType) stupid_theta
tc_rhs tc_rhs
...@@ -720,7 +732,15 @@ tcDataFamInstDecl mb_clsinfo ...@@ -720,7 +732,15 @@ tcDataFamInstDecl mb_clsinfo
-- Remember to check validity; no recursion to worry about here -- Remember to check validity; no recursion to worry about here
; checkValidTyCon rep_tc ; checkValidTyCon rep_tc
; return fam_inst } }
; let m_deriv_info = case derivs of
Nothing -> Nothing
Just (L _ preds) ->
Just $ DerivInfo { di_rep_tc = rep_tc
, di_preds = preds
, di_ctxt = tcMkDataFamInstCtxt decl }
; return (fam_inst, m_deriv_info) } }
where where
-- See Note [Eta reduction for data family axioms] -- See Note [Eta reduction for data family axioms]
-- [a,b,c,d].T [a] c Int c d ==> [a,b,c]. T [a] c Int c -- [a,b,c,d].T [a] c Int c d ==> [a,b,c]. T [a] c Int c
......
...@@ -1230,7 +1230,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls ...@@ -1230,7 +1230,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls
-- Note [AFamDataCon: not promoting data family constructors] -- Note [AFamDataCon: not promoting data family constructors]
do { tcg_env <- tcTyAndClassDecls tycl_decls ; do { tcg_env <- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $ ; setGblEnv tcg_env $
tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls } tcInstDecls1 tycl_decls inst_decls deriv_decls }
where where
-- get_cons extracts the *constructor* bindings of the declaration -- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl Name -> [Name] get_cons :: LInstDecl Name -> [Name]
......
...@@ -15,7 +15,7 @@ module TcTyClsDecls ( ...@@ -15,7 +15,7 @@ module TcTyClsDecls (
-- data/type family instance declarations -- data/type family instance declarations
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcFamTyPats, tcTyFamInstEqn, famTyConShape,
tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
wrongKindOfFamily, dataConCtxt, badDataConTyCon wrongKindOfFamily, dataConCtxt, badDataConTyCon
) where ) where
...@@ -721,7 +721,7 @@ tcFamDecl1 parent ...@@ -721,7 +721,7 @@ tcFamDecl1 parent
; tc_kind <- kcLookupKind tc_name ; tc_kind <- kcLookupKind tc_name
; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind)
; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns
-- Do not attempt to drop equations dominated by earlier -- Do not attempt to drop equations dominated by earlier
-- ones here; in the case of mutual recursion with a data -- ones here; in the case of mutual recursion with a data
-- type, we get a knot-tying failure. Instead we check -- type, we get a knot-tying failure. Instead we check
...@@ -950,17 +950,18 @@ kcTyFamInstEqn fam_tc_shape ...@@ -950,17 +950,18 @@ kcTyFamInstEqn fam_tc_shape
(L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty })) (L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty }))
= setSrcSpan loc $ = setSrcSpan loc $
discardResult $ discardResult $
tc_fam_ty_pats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
pats (discardResult . (tcCheckLHsType hs_ty))
tcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM CoAxBranch tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch
-- Needs to be here, not in TcInstDcls, because closed families -- Needs to be here, not in TcInstDcls, because closed families
-- (typechecked here) have TyFamInstEqns -- (typechecked here) have TyFamInstEqns
tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats , tfe_pats = pats
, tfe_rhs = hs_ty })) , tfe_rhs = hs_ty }))
= setSrcSpan loc $ = setSrcSpan loc $
tcFamTyPats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) $ tcFamTyPats fam_tc_shape mb_clsinfo pats (discardResult . (tcCheckLHsType hs_ty)) $
\tvs' pats' res_kind -> \tvs' pats' res_kind ->
do { checkTc (fam_tc_name == eqn_tc_name) do { checkTc (fam_tc_name == eqn_tc_name)
(wrongTyFamName fam_tc_name eqn_tc_name) (wrongTyFamName fam_tc_name eqn_tc_name)
...@@ -1042,6 +1043,7 @@ famTyConShape fam_tc ...@@ -1042,6 +1043,7 @@ famTyConShape fam_tc
, tyConKind fam_tc ) , tyConKind fam_tc )
tc_fam_ty_pats :: FamTyConShape tc_fam_ty_pats :: FamTyConShape
-> Maybe ClsInfo
-> HsWithBndrs Name [LHsType Name] -- Patterns -> HsWithBndrs Name [LHsType Name] -- Patterns
-> (TcKind -> TcM ()) -- Kind checker for RHS -> (TcKind -> TcM ()) -- Kind checker for RHS
-- result is ignored -- result is ignored
...@@ -1057,24 +1059,28 @@ tc_fam_ty_pats :: FamTyConShape ...@@ -1057,24 +1059,28 @@ tc_fam_ty_pats :: FamTyConShape
-- In that case, the type variable 'a' will *already be in scope* -- In that case, the type variable 'a' will *already be in scope*
-- (and, if C is poly-kinded, so will its kind parameter). -- (and, if C is poly-kinded, so will its kind parameter).
tc_fam_ty_pats (name, arity, kind) tc_fam_ty_pats (name, arity, kind) mb_clsinfo
(HsWB { hswb_cts = arg_pats, hswb_kvs = kvars (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars
, hswb_tvs = tvars, hswb_wcs = wcs }) , hswb_tvs = tvars, hswb_wcs = wcs })
kind_checker kind_checker
= do { let (fam_kvs, fam_body) = splitForAllTys kind = do { let (fam_kvs, fam_body) = splitForAllTys kind
-- We wish to check that the pattern has the right number of arguments -- The splitKindFunTysN below will panic
-- in checkValidFamPats (in TcValidity), so we can do the check *after* -- if there are too many patterns. So, we do a validity check here.
-- we're done with the knot. But, the splitKindFunTysN below will panic
-- if there are *too many* patterns. So, we do a preliminary check here.
-- Note that we don't have enough information at hand to do a full check,
-- as that requires the full declared arity of the family, which isn't
-- nearby.
; checkTc (length arg_pats == arity) $ ; checkTc (length arg_pats == arity) $