summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2012-03-22 21:10:34 +0000
committerSimon Peyton Jones <simonpj@microsoft.com>2012-03-22 21:10:34 +0000
commitb857c8ad367877f424b5fca50bd45199f39f86c7 (patch)
tree7fcf7fbfce0d823d1cee6ea45df9ec2083b2545c
parentca7c3a0e1aba18379548b76775181bf464214ae3 (diff)
downloadhaskell-b857c8ad367877f424b5fca50bd45199f39f86c7.tar.gz
Refactor HsDecls.TyClDecl to extract the type HsTyDefn, which is the
RHS of a data type or type synonym declaration. This can be shared between type declarations and type *instance* declarations.
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs146
-rw-r--r--compiler/hsSyn/Convert.lhs135
-rw-r--r--compiler/hsSyn/HsDecls.lhs363
-rw-r--r--compiler/hsSyn/HsUtils.lhs48
-rw-r--r--compiler/main/HscStats.lhs12
-rw-r--r--compiler/parser/Parser.y.pp56
-rw-r--r--compiler/parser/ParserCore.y22
-rw-r--r--compiler/parser/RdrHsSyn.lhs157
-rw-r--r--compiler/rename/RnEnv.lhs19
-rw-r--r--compiler/rename/RnNames.lhs9
-rw-r--r--compiler/rename/RnSource.lhs234
-rw-r--r--compiler/rename/RnTypes.lhs66
-rw-r--r--compiler/typecheck/TcClassDcl.lhs13
-rw-r--r--compiler/typecheck/TcDeriv.lhs104
-rw-r--r--compiler/typecheck/TcInstDcls.lhs45
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs214
16 files changed, 807 insertions, 836 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index a6d878a703..535a62caeb 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -134,7 +134,7 @@ repTopDs group
-- more needed
return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ fix_ds
- ++ catMaybes inst_ds ++ for_ds) }) ;
+ ++ inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
@@ -194,53 +194,12 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
; return $ Just (loc, dec)
}
-repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, tcdKindSig = mb_kind,
- tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
- tcdCons = cons, tcdDerivs = mb_derivs }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; tc_tvs <- mk_extra_tvs tvs mb_kind
- ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
- do { cxt1 <- repLContext cxt
- ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
- ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
- ; cons1 <- mapM (repC (hsLTyVarNames tc_tvs)) cons
- ; cons2 <- coreList conQTyConName cons1
- ; derivs1 <- repDerivs mb_derivs
- ; bndrs1 <- coreList tyVarBndrTyConName bndrs
- ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
- }
- ; return $ Just (loc, dec)
- }
-
-repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, tcdKindSig = mb_kind,
- tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
- tcdCons = [con], tcdDerivs = mb_derivs }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; tc_tvs <- mk_extra_tvs tvs mb_kind
+repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn }))
+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
+ ; tc_tvs <- mk_extra_tvs tc tvs defn
; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
- do { cxt1 <- repLContext cxt
- ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
- ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
- ; con1 <- repC (hsLTyVarNames tc_tvs) con
- ; derivs1 <- repDerivs mb_derivs
- ; bndrs1 <- coreList tyVarBndrTyConName bndrs
- ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
- }
- ; return $ Just (loc, dec)
- }
-
-repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
- tcdSynRhs = ty }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
- ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
- ; ty1 <- repLTy ty
- ; bndrs1 <- coreList tyVarBndrTyConName bndrs
- ; repTySyn tc1 bndrs1 opt_tys2 ty1
- }
- ; return (Just (loc, dec))
- }
+ repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
+ ; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds,
@@ -254,8 +213,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; fds1 <- repLFunDeps fds
; ats1 <- repTyClDs ats
; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
- ; bndrs1 <- coreList tyVarBndrTyConName bndrs
- ; repClass cxt1 cls1 bndrs1 fds1 decls1
+ ; repClass cxt1 cls1 bndrs fds1 decls1
}
; return $ Just (loc, dec)
}
@@ -266,22 +224,45 @@ repTyClD (L loc d) = putSrcSpanDs loc $
; return Nothing }
-------------------------
-mk_extra_tvs :: [LHsTyVarBndr Name] -> Maybe (HsBndrSig (LHsKind Name)) -> DsM [LHsTyVarBndr Name]
+repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr]
+ -> Maybe (Core [TH.TypeQ])
+ -> [Name] -> HsTyDefn Name
+ -> DsM (Core TH.DecQ)
+repTyDefn tc bndrs opt_tys tv_names
+ (TyData { td_ND = new_or_data, td_ctxt = cxt
+ , td_cons = cons, td_derivs = mb_derivs })
+ = do { cxt1 <- repLContext cxt
+ ; derivs1 <- repDerivs mb_derivs
+ ; case new_or_data of
+ NewType -> do { con1 <- repC tv_names (head cons)
+ ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
+ DataType -> do { cons1 <- mapM (repC tv_names) cons
+ ; cons2 <- coreList conQTyConName cons1
+ ; repData cxt1 tc bndrs opt_tys cons2 derivs1 } }
+
+repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
+ = do { ty1 <- repLTy ty
+ ; repTySyn tc bndrs opt_tys ty1 }
+
+-------------------------
+mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name]
+ -> HsTyDefn Name -> DsM [LHsTyVarBndr Name]
-- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
-mk_extra_tvs tvs Nothing
- = return tvs
-mk_extra_tvs tvs (Just (HsBSig hs_kind _))
+mk_extra_tvs tc tvs defn
+ | TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn
= do { extra_tvs <- go hs_kind
; return (tvs ++ extra_tvs) }
+ | otherwise
+ = return tvs
where
go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
go (L loc (HsFunTy kind rest))
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
- ; hs_tv = L loc (KindedTyVar nm (HsBSig kind placeHolderBndrs)) }
+ ; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
@@ -289,9 +270,7 @@ mk_extra_tvs tvs (Just (HsBSig hs_kind _))
| n == liftedTypeKindTyConName
= return []
- go _ = failWithDs (hang (ptext (sLit "Malformed kind signature"))
- 2 (ppr hs_kind))
-
+ go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
-------------------------
-- represent fundeps
@@ -314,14 +293,27 @@ repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName []
--- represent instance declarations
+-- represent associated family declarations
--
-repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
-repInstD (L loc (FamInstDecl fi_decl))
- = repTyClD (L loc fi_decl)
-
+repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
+repLAssocFamilys = mapM repLAssocFamily
+ where
+ repLAssocFamily tydecl@(L _ (TyFamily {}))
+ = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
+ repLAssocFamily tydecl
+ = failWithDs msg
+ where
+ msg = ptext (sLit "Illegal associated declaration in class:") <+>
+ ppr tydecl
+
+-- Represent instance declarations
+--
+repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repInstD (L loc (FamInstD fi_decl))
+ = do { dec <- repFamInstD fi_decl
+ ; return (loc, dec) }
-repInstD (L loc (ClsInstDecl ty binds prags ats))
+repInstD (L loc (ClsInstD ty binds prags ats))
= do { dec <- addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
@@ -338,13 +330,23 @@ repInstD (L loc (ClsInstDecl ty binds prags ats))
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags
- ; ats1 <- repTyClDs ats
+ ; ats1 <- mapM (repFamInstD . unLoc) ats
; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls }
- ; return (Just (loc, dec)) }
+ ; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
+repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
+repFamInstD (FamInstDecl { fid_tycon = tc_name, fid_pats = HsBSig tys tv_names, fid_defn = defn })
+ = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
+ ; let loc = getLoc tc_name
+ hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk
+ ; addTyVarBinds hs_tvs $ \ bndrs ->
+ do { tys1 <- repLTys tys
+ ; tys2 <- coreList typeQTyConName tys1
+ ; repTyDefn tc bndrs (Just tys2) tv_names defn } }
+
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
= do MkC name' <- lookupLOcc name
@@ -414,8 +416,7 @@ repC tvs (L _ (ConDecl { con_name = con
do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
; c' <- repConstr con1 details
; ctxt' <- repContext (eq_ctxt ++ ctxt)
- ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs
- ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } }
+ ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
in_subst :: Name -> [(Name,Name)] -> Bool
in_subst _ [] = False
@@ -591,7 +592,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
--
type ProcessTyVarBinds a =
[LHsTyVarBndr Name] -- the binders to be added
- -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
+ -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment;
@@ -602,13 +603,13 @@ addTyVarBinds :: ProcessTyVarBinds a
addTyVarBinds tvs m
= do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
; term <- addBinds freshNames $
- do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames)
- ; m kindedBndrs }
+ do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames)
+ ; kbs2 <- coreList tyVarBndrTyConName kbs1
+ ; m kbs2 }
; wrapGenSyms freshNames term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
-
addTyClTyVarBinds :: ProcessTyVarBinds a
-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
@@ -686,8 +687,7 @@ repTy (HsForAllTy _ tvs ctxt ty) =
addTyVarBinds tvs $ \bndrs -> do
ctxt1 <- repLContext ctxt
ty1 <- repLTy ty
- bndrs1 <- coreList tyVarBndrTyConName bndrs
- repTForall bndrs1 ctxt1 ty1
+ repTForall bndrs ctxt1 ty1
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 23ffd6f3c1..d5f1d718b6 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -31,7 +31,6 @@ import TysWiredIn
import BasicTypes as Hs
import ForeignCall
import Unique
-import MonadUtils
import ErrUtils
import Bag
import Util
@@ -42,7 +41,6 @@ import Control.Monad( unless )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
-
import GHC.Exts
-------------------------------------------------------------------
@@ -165,45 +163,52 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
- ; returnL $ TyClD (TySynonym { tcdLName = tc'
- , tcdTyVars = tvs', tcdTyPats = Nothing
- , tcdSynRhs = rhs', tcdFVs = placeHolderNames }) }
+ ; returnL $ TyClD (TyDecl { tcdLName = tc'
+ , tcdTyVars = tvs'
+ , tcdTyDefn = TySynonym rhs'
+ , tcdFVs = placeHolderNames }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
- ; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing
- , tcdLName = tc', tcdCtxt = ctxt'
- , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
- , tcdCons = cons', tcdDerivs = derivs' }) }
+ ; let defn = TyData { td_ND = DataType, td_cType = Nothing
+ , td_ctxt = ctxt'
+ , td_kindSig = Nothing
+ , td_cons = cons', td_derivs = derivs' }
+ ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
+ , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
- ; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing
- , tcdLName = tc', tcdCtxt = ctxt'
- , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
- , tcdCons = [con'], tcdDerivs = derivs'}) }
+ ; let defn = TyData { td_ND = DataType, td_cType = Nothing
+ , td_ctxt = ctxt'
+ , td_kindSig = Nothing
+ , td_cons = [con'], td_derivs = derivs' }
+ ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
+ , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
- ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
- ; returnL $
- TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
- , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
- , tcdATs = ats', tcdATDefs = [], tcdDocs = [] }
- -- no docs in TH ^^
+ ; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+ ; returnL $ TyClD $
+ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+ , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
+ , tcdATs = fams', tcdATDefs = ats', tcdDocs = [] }
+ -- no docs in TH ^^
}
cvtDec (InstanceD ctxt ty decs)
- = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
+ = do { let doc = ptext (sLit "an instance declaration")
+ ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs
+ ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
- ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') }
+ ; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
@@ -218,47 +223,50 @@ cvtDec (FamilyD flav tc tvs kind)
cvtFamFlavour DataFam = DataFamily
cvtDec (DataInstD ctxt tc tys constrs derivs)
- = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
+ = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
- ; returnL $ InstD $ FamInstDecl $
- TyData { tcdND = DataType, tcdCType = Nothing
- , tcdLName = tc', tcdCtxt = ctxt'
- , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
- , tcdCons = cons', tcdDerivs = derivs' } }
+ ; let defn = TyData { td_ND = DataType, td_cType = Nothing
+ , td_ctxt = ctxt'
+ , td_kindSig = Nothing
+ , td_cons = cons', td_derivs = derivs' }
+
+ ; returnL $ InstD $ FamInstD $
+ FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
- = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
+ = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
- ; returnL $ InstD $ FamInstDecl $
- TyData { tcdND = NewType, tcdCType = Nothing
- , tcdLName = tc', tcdCtxt = ctxt'
- , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
- , tcdCons = [con'], tcdDerivs = derivs' } }
+ ; let defn = TyData { td_ND = NewType, td_cType = Nothing
+ , td_ctxt = ctxt'
+ , td_kindSig = Nothing
+ , td_cons = [con'], td_derivs = derivs' }
+ ; returnL $ InstD $ FamInstD $
+ FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
cvtDec (TySynInstD tc tys rhs)
- = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
+ = do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
- ; returnL $ InstD $ FamInstDecl $
- TySynonym { tcdLName = tc'
- , tcdTyVars = tvs', tcdTyPats = tys'
- , tcdSynRhs = rhs', tcdFVs = placeHolderNames } }
+ ; returnL $ InstD $ FamInstD $
+ FamInstDecl { fid_tycon = tc', fid_pats = tys', fid_defn = TySynonym rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
- [LTyClDecl RdrName])
+ [LTyClDecl RdrName], -- Family decls
+ [LFamInstDecl RdrName])
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
= do { decs' <- mapM cvtDec decs
; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs'
- ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
- ; let (binds', bads) = partitionWith is_bind prob_binds'
+ ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
+ ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
+ ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
; unless (null bads) (failWith (mkBadDecMsg doc bads))
- ; return (listToBag binds', sigs', ats') }
+ ; return (listToBag binds', sigs', fams', ats') }
----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
@@ -275,40 +283,25 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName
, Located RdrName
- , [LHsTyVarBndr RdrName]
- , Maybe [LHsType RdrName])
+ , HsBndrSig [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
- ; tvs <- concatMapM collect tys
- ; tvs' <- cvtTvs tvs
; tys' <- mapM cvtType tys
- ; return (cxt', tc', tvs', Just tys')
- }
- where
- collect (ForallT _ _ _)
- = failWith $ text "Forall type not allowed as type parameter"
- collect (VarT tv) = return [PlainTV tv]
- collect (ConT _) = return []
- collect (TupleT _) = return []
- collect (UnboxedTupleT _) = return []
- collect ArrowT = return []
- collect ListT = return []
- collect (AppT t1 t2)
- = do { tvs1 <- collect t1
- ; tvs2 <- collect t2
- ; return $ tvs1 ++ tvs2
- }
- collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
- collect (SigT ty _) = collect ty
+ ; return (cxt', tc', mkHsBSig tys') }
+
-------------------------------------------------------------------
-- Partitioning declarations
-------------------------------------------------------------------
-is_fam_inst :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
-is_fam_inst (L loc (Hs.InstD (FamInstDecl d))) = Left (L loc d)
-is_fam_inst decl = Right decl
+is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
+is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d)
+is_fam_decl decl = Right decl
+
+is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName)
+is_fam_inst (L loc (Hs.InstD (FamInstD d))) = Left (L loc d)
+is_fam_inst decl = Right decl
is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
@@ -318,7 +311,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
is_bind decl = Right decl
-mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc
+mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
= sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
, nest 2 (vcat (map Outputable.ppr bads)) ]
@@ -764,7 +757,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) }
+ ; return $ SigPatIn p' (mkHsBSig t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
@@ -799,7 +792,7 @@ cvt_tv (TH.PlainTV nm)
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
- ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) }
+ ; returnL $ KindedTyVar nm' (mkHsBSig ki') }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
@@ -883,7 +876,7 @@ cvtKind (ArrowK k1 k2) = do
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
- ; return (Just (HsBSig ki' placeHolderBndrs)) }
+ ; return (Just (mkHsBSig ki')) }
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index d3231696fa..b54327a48e 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -12,16 +12,16 @@
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
module HsDecls (
-- * Toplevel declarations
- HsDecl(..), LHsDecl,
+ HsDecl(..), LHsDecl, HsTyDefn(..),
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, TyClGroup,
- isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
- isFamInstDecl, tcdName, tyClDeclTyVars,
- countTyClDecls,
+ isClassDecl, isDataDecl, isSynDecl, isFamilyDecl,
+ isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName,
+ countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
- FamInstDecl, LFamInstDecl, instDeclFamInsts,
+ FamInstDecl(..), LFamInstDecl, instDeclFamInsts,
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
@@ -80,7 +80,6 @@ import FastString
import Bag
import Control.Monad ( liftM )
import Data.Data hiding (TyCon)
-import Data.Maybe ( isJust )
\end{code}
%************************************************************************
@@ -414,27 +413,6 @@ Interface file code:
\begin{code}
--- Representation of indexed types
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Family kind signatures are represented by the variant `TyFamily'. It
--- covers "type family", "newtype family", and "data family" declarations,
--- distinguished by the value of the field `tcdFlavour'.
---
--- Indexed types are represented by 'TyData' and 'TySynonym' using the field
--- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
---
--- * If it is 'Nothing', we have a *vanilla* data type declaration or type
--- synonym declaration and 'tcdVars' contains the type parameters of the
--- type constructor.
---
--- * If it is 'Just pats', we have the definition of an indexed type. Then,
--- 'pats' are type patterns for the type-indexes of the type constructor
--- and 'tcdTyVars' are the variables in those patterns. Hence, the arity of
--- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
--- *not* 'length tcdVars'.
---
--- In both cases, 'tcdVars' collects all variables we need to quantify over.
-
type LTyClDecl name = Located (TyClDecl name)
type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent
-- strongly connected components of decls
@@ -447,7 +425,6 @@ data TyClDecl name
tcdExtName :: Maybe FastString
}
-
| -- | @type/data family T :: *->*@
TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
@@ -456,55 +433,12 @@ data TyClDecl name
}
- | -- | Declares a data type or newtype, giving its construcors
- -- @
- -- data/newtype T a = <constrs>
- -- data/newtype instance T [a] = <constrs>
- -- @
- TyData { tcdND :: NewOrData,
- tcdCtxt :: LHsContext name, -- ^ Context
- tcdLName :: Located name, -- ^ Type constructor
-
- tcdCType :: Maybe CType,
- tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables
- tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
- -- See Note [tcdTyVars and tcdTyPats]
-
- tcdKindSig:: Maybe (HsBndrSig (LHsKind name)),
- -- ^ Optional kind signature.
- --
- -- @(Just k)@ for a GADT-style @data@, or @data
- -- instance@ decl with explicit kind sig
-
- tcdCons :: [LConDecl name],
- -- ^ Data constructors
- --
- -- For @data T a = T1 | T2 a@
- -- the 'LConDecl's all have 'ResTyH98'.
- -- For @data T a where { T1 :: T a }@
- -- the 'LConDecls' all have 'ResTyGADT'.
-
- tcdDerivs :: Maybe [LHsType name]
- -- ^ Derivings; @Nothing@ => not specified,
- -- @Just []@ => derive exactly what is asked
- --
- -- These "types" must be of form
- -- @
- -- forall ab. C ty1 ty2
- -- @
- -- Typically the foralls and ty args are empty, but they
- -- are non-empty for the newtype-deriving case
- }
-
- | TySynonym { tcdLName :: Located name, -- ^ type constructor
- tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables
- tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns
- -- See Note [tcdTyVars and tcdTyPats]
-
- tcdSynRhs :: LHsType name, -- ^ synonym expansion
- tcdFVs :: NameSet -- ^ Free tycons of the decl
- -- (Used for cycle detection)
- }
+ | -- | @type/data declaration
+ TyDecl { tcdLName :: Located name -- ^ Type constructor
+ , tcdTyVars :: [LHsTyVarBndr name]
+ , tcdTyDefn :: HsTyDefn name
+ , tcdFVs :: NameSet } -- ^ Free tycons of the decl
+ -- (Used for cycle detection)
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class
@@ -520,6 +454,47 @@ data TyClDecl name
}
deriving (Data, Typeable)
+
+data HsTyDefn name -- The payload of a type synonym or data type defn
+ -- Used *both* for vanialla type/data declarations,
+ -- *and* for type/data family instances
+ = TySynonym { td_synRhs :: LHsType name } -- ^ Synonym expansion
+
+ | -- | Declares a data type or newtype, giving its construcors
+ -- @
+ -- data/newtype T a = <constrs>
+ -- data/newtype instance T [a] = <constrs>
+ -- @
+ TyData { td_ND :: NewOrData,
+ td_ctxt :: LHsContext name, -- ^ Context
+ td_cType :: Maybe CType,
+ td_kindSig:: Maybe (HsBndrSig (LHsKind name)),
+ -- ^ Optional kind signature.
+ --
+ -- @(Just k)@ for a GADT-style @data@, or @data
+ -- instance@ decl with explicit kind sig
+
+ td_cons :: [LConDecl name],
+ -- ^ Data constructors
+ --
+ -- For @data T a = T1 | T2 a@
+ -- the 'LConDecl's all have 'ResTyH98'.
+ -- For @data T a where { T1 :: T a }@
+ -- the 'LConDecls' all have 'ResTyGADT'.
+
+ td_derivs :: Maybe [LHsType name]
+ -- ^ Derivings; @Nothing@ => not specified,
+ -- @Just []@ => derive exactly what is asked
+ --
+ -- These "types" must be of form
+ -- @
+ -- forall ab. C ty1 ty2
+ -- @
+ -- Typically the foralls and ty args are empty, but they
+ -- are non-empty for the newtype-deriving case
+ }
+ deriving( Data, Typeable )
+
data NewOrData
= NewType -- ^ @newtype Blah ...@
| DataType -- ^ @data Blah ...@
@@ -531,53 +506,39 @@ data FamilyFlavour
deriving (Data, Typeable)
\end{code}
-Note [tcdTyVars and tcdTyPats]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [tcdTypats and HsTyPats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use TyData and TySynonym both for vanilla data/type declarations
type T a = Int
AND for data/type family instance declarations
type instance F [a] = (a,Int)
-tcdTyPats = Nothing
+tcdTyPats = HsTyDefn tvs
This is a vanilla data type or type synonym
- tcdTyVars are the quantified type variables
+ tvs are the quantified type variables
-tcdTyPats = Just tys
- This is a data/type family instance declaration
- tcdTyVars are fv(tys)
-
- Eg class C s t where
- type F t p :: *
- instance C w (a,b) where
- type F (a,b) x = x->a
- The tcdTyVars of the F decl are {a,b,x}, even though the F decl
- is nested inside the 'instance' decl.
-
- However after the renamer, the uniques will match up:
- instance C w7 (a8,b9) where
- type F (a8,b9) x10 = x10->a8
- so that we can compare the type patter in the 'instance' decl and
- in the associated 'type' decl
------------------------------
Simple classifiers
\begin{code}
--- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@
+isHsDataDefn, isHsSynDefn :: HsTyDefn name -> Bool
+isHsDataDefn (TyData {}) = True
+isHsDataDefn _ = False
+
+isHsSynDefn (TySynonym {}) = True
+isHsSynDefn _ = False
+
+-- | @True@ <=> argument is a @data@\/@newtype@
-- declaration.
isDataDecl :: TyClDecl name -> Bool
-isDataDecl (TyData {}) = True
-isDataDecl _other = False
+isDataDecl (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn
+isDataDecl _other = False
-- | type or type instance declaration
-isTypeDecl :: TyClDecl name -> Bool
-isTypeDecl (TySynonym {}) = True
-isTypeDecl _other = False
-
--- | vanilla Haskell type synonym (ie, not a type instance)
isSynDecl :: TyClDecl name -> Bool
-isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
-isSynDecl _other = False
+isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn
+isSynDecl _other = False
-- | type class
isClassDecl :: TyClDecl name -> Bool
@@ -588,27 +549,16 @@ isClassDecl _ = False
isFamilyDecl :: TyClDecl name -> Bool
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other = False
-
--- | family instance (types, newtypes, and data types)
-isFamInstDecl :: TyClDecl name -> Bool
-isFamInstDecl tydecl
- | isTypeDecl tydecl
- || isDataDecl tydecl = isJust (tcdTyPats tydecl)
- | otherwise = False
\end{code}
Dealing with names
\begin{code}
+famInstDeclName :: LFamInstDecl a -> a
+famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name
+
tcdName :: TyClDecl name -> name
tcdName decl = unLoc (tcdLName decl)
-
-tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
-tyClDeclTyVars (TyFamily {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ForeignType {}) = []
\end{code}
\begin{code}
@@ -621,11 +571,11 @@ countTyClDecls decls
count isNewTy decls, -- ...instances
count isFamilyDecl decls)
where
- isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
- isDataTy _ = False
+ isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True
+ isDataTy _ = False
- isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
- isNewTy _ = False
+ isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True
+ isNewTy _ = False
\end{code}
\begin{code}
@@ -637,7 +587,7 @@ instance OutputableBndr name
ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
tcdTyVars = tyvars, tcdKindSig = mb_kind})
- = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
+ = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
where
pp_flavour = case flavour of
TypeFamily -> ptext (sLit "type family")
@@ -647,27 +597,8 @@ instance OutputableBndr name
Nothing -> empty
Just kind -> dcolon <+> ppr kind
- ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
- tcdSynRhs = mono_ty})
- = hang (ptext (sLit "type") <+>
- (if isJust typats then ptext (sLit "instance") else empty) <+>
- pp_decl_head [] ltycon tyvars typats <+>
- equals)
- 4 (ppr mono_ty)
-
- ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
- tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig,
- tcdCons = condecls, tcdDerivs = derivings})
- = pp_tydecl (null condecls && isJust mb_sig)
- (ppr new_or_data <+>
- (if isJust typats then ptext (sLit "instance") else empty) <+>
- pp_decl_head (unLoc context) ltycon tyvars typats <+>
- ppr_sigx mb_sig)
- (pp_condecls condecls)
- derivings
- where
- ppr_sigx Nothing = empty
- ppr_sigx (Just (HsBSig kind _)) = dcolon <+> ppr kind
+ ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+ = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
@@ -683,20 +614,25 @@ instance OutputableBndr name
pprLHsBindsForUser methods sigs) ]
where
top_matter = ptext (sLit "class")
- <+> pp_decl_head (unLoc context) lclas tyvars Nothing
+ <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
<+> pprFundeps (map unLoc fds)
-pp_decl_head :: OutputableBndr name
- => HsContext name
- -> Located name
+pp_vanilla_decl_head :: OutputableBndr name
+ => Located name
-> [LHsTyVarBndr name]
- -> Maybe [LHsType name]
+ -> HsContext name
-> SDoc
-pp_decl_head context thing tyvars Nothing -- no explicit type patterns
- = hsep [pprHsContext context, ppr thing, interppSP tyvars]
-pp_decl_head context thing _ (Just typats) -- explicit type patterns
- = hsep [ pprHsContext context, ppr thing
- , hsep (map (pprParendHsType.unLoc) typats)]
+pp_vanilla_decl_head thing tyvars context
+ = hsep [pprHsContext context, ppr thing, interppSP tyvars]
+
+pp_fam_inst_head :: OutputableBndr name
+ => Located name
+ -> HsBndrSig [LHsType name]
+ -> HsContext name
+ -> SDoc
+pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns
+ = hsep [ ptext (sLit "instancs"), pprHsContext context, ppr thing
+ , hsep (map (pprParendHsType.unLoc) typats)]
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
@@ -704,20 +640,48 @@ pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
-pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
-pp_tydecl True pp_head _ _
- = pp_head
-pp_tydecl False pp_head pp_decl_rhs derivings
- = hang pp_head 4 (sep [
- pp_decl_rhs,
- case derivings of
- Nothing -> empty
- Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
- ])
+pp_ty_defn :: OutputableBndr name
+ => (HsContext name -> SDoc) -- Printing the header
+ -> HsTyDefn name
+ -> SDoc
+
+pp_ty_defn pp_hdr (TySynonym rhs)
+ = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals)
+ 4 (ppr rhs)
+
+pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
+ , td_kindSig = mb_sig
+ , td_cons = condecls, td_derivs = derivings })
+ | null condecls
+ = ppr new_or_data <+> pp_hdr context <+> pp_sig
+
+ | otherwise
+ = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
+ 2 (pp_condecls condecls $$ pp_derivings)
+ where
+ pp_sig = case mb_sig of
+ Nothing -> empty
+ Just (HsBSig kind _) -> dcolon <+> ppr kind
+ pp_derivings = case derivings of
+ Nothing -> empty
+ Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
+
+instance OutputableBndr name => Outputable (HsTyDefn name) where
+ ppr d = pp_ty_defn (\_ -> ptext (sLit "Naked HsTyDefn")) d
instance Outputable NewOrData where
ppr NewType = ptext (sLit "newtype")
ppr DataType = ptext (sLit "data")
+
+pprTyDefnFlavour :: HsTyDefn a -> SDoc
+pprTyDefnFlavour (TyData { td_ND = nd }) = ppr nd
+pprTyDefnFlavour (TySynonym {}) = ptext (sLit "type")
+
+pprTyClDeclFlavour :: TyClDecl a -> SDoc
+pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
+pprTyClDeclFlavour (TyFamily {}) = ptext (sLit "family")
+pprTyClDeclFlavour (TyDecl { tcdTyDefn = defn }) = pprTyDefnFlavour defn
+pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
\end{code}
@@ -840,27 +804,58 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
%************************************************************************
\begin{code}
-type LInstDecl name = Located (InstDecl name)
-
type LFamInstDecl name = Located (FamInstDecl name)
-type FamInstDecl name = TyClDecl name -- Type or data family instance
+data FamInstDecl name
+ = FamInstDecl
+ { fid_tycon :: Located name
+ , fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs)
+ , fid_defn :: HsTyDefn name } -- Type or data family instance
+ deriving( Typeable, Data )
+type LInstDecl name = Located (InstDecl name)
data InstDecl name -- Both class and family instances
- = ClsInstDecl
- (LHsType name) -- Context => Class Instance-type
- -- Using a polytype means that the renamer conveniently
- -- figures out the quantified type variables for us.
- (LHsBinds name)
- [LSig name] -- User-supplied pragmatic info
- [LFamInstDecl name] -- Family instances for associated types
-
- | FamInstDecl -- type/data family instance
+ = ClsInstD
+ { cid_poly_ty :: LHsType name -- Context => Class Instance-type
+ -- Using a polytype means that the renamer conveniently
+ -- figures out the quantified type variables for us.
+ , cid_binds :: LHsBinds name
+ , cid_sigs :: [LSig name] -- User-supplied pragmatic info
+ , cid_fam_insts :: [LFamInstDecl name] } -- Family instances for associated types
+
+ | FamInstD -- type/data family instance
(FamInstDecl name)
deriving (Data, Typeable)
+\end{code}
+
+Note [Family instance declaration binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A FamInstDecl is a data/type family instance declaration
+the fid_pats field is LHS patterns, and the tvs of the HsBSig
+tvs are fv(pat_tys), *including* ones that are already in scope
+
+ Eg class C s t where
+ type F t p :: *
+ instance C w (a,b) where
+ type F (a,b) x = x->a
+ The tcdTyVars of the F decl are {a,b,x}, even though the F decl
+ is nested inside the 'instance' decl.
+
+ However after the renamer, the uniques will match up:
+ instance C w7 (a8,b9) where
+ type F (a8,b9) x10 = x10->a8
+ so that we can compare the type patter in the 'instance' decl and
+ in the associated 'type' decl
+
+\begin{code}
+instance (OutputableBndr name) => Outputable (FamInstDecl name) where
+ ppr (FamInstDecl { fid_tycon = tycon
+ , fid_pats = pats
+ , fid_defn = defn })
+ = pp_ty_defn (pp_fam_inst_head tycon pats) defn
instance (OutputableBndr name) => Outputable (InstDecl name) where
- ppr (ClsInstDecl inst_ty binds sigs ats)
+ ppr (ClsInstD inst_ty binds sigs ats)
| null sigs && null ats && isEmptyBag binds -- No "where" part
= top_matter
@@ -871,16 +866,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
- ppr (FamInstDecl decl) = ppr decl
+ ppr (FamInstD decl) = ppr decl
-- Extract the declarations of associated types from an instance
-instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name]
+instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
instDeclFamInsts inst_decls
= concatMap do_one inst_decls
where
- do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts
- do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst]
+ do_one (L _ (ClsInstD _ _ _ fam_insts)) = map unLoc fam_insts
+ do_one (L _ (FamInstD fam_inst)) = [fam_inst]
\end{code}
%************************************************************************
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 729532da2a..88c09387db 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -33,7 +33,7 @@ module HsUtils(
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
- mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
+ mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
@@ -69,7 +69,7 @@ module HsUtils(
collectSigTysFromPats, collectSigTysFromPat,
hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
- hsForeignDeclsBinders, hsGroupBinders,
+ hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -96,7 +96,6 @@ import Util
import Bag
import Data.Either
-import Data.Maybe
\end{code}
@@ -266,6 +265,9 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
+mkHsBSig :: a -> HsBndrSig a
+mkHsBSig x = HsBSig x placeHolderBndrs
+
-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
@@ -622,9 +624,10 @@ hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
- = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
- , L _ n <- hsLTyClDeclBinders d]
+ = map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++
+ concatMap (hsInstDeclBinders . unLoc) inst_decls)
+-------------------
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
-- The first one is guaranteed to be the name of the decl. For record fields
@@ -632,24 +635,37 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- occurence. We use the equality to filter out duplicate field names
hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
+-------------------
hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name]
hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
-hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
+hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
+ , tcdATs = ats, tcdATDefs = fam_insts })
= cls_name :
- concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
-
-hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats })
- | isJust mb_pats = []
- | otherwise = [name]
- -- See Note [Binders in family instances]
-
-hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
- | isJust mb_pats = hsConDeclsBinders cons
- | otherwise = tc_name : hsConDeclsBinders cons
+ concatMap hsLTyClDeclBinders ats ++
+ concatMap (hsFamInstBinders . unLoc) fam_insts ++
+ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
+
+hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
+ = name : hsTyDefnBinders defn
+
+-------------------
+hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
+hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
+hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi
+
+-------------------
+hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
+hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
+
+-------------------
+hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
+hsTyDefnBinders (TySynonym {}) = []
+hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
+-------------------
hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
-- See hsTyClDeclBinders for what this does
-- The function is boringly complicated because of the records
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index 168e49af4a..b5fe0fdf86 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
- data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
+ data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just ds -> length ds)
data_info _ = (0,0)
@@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
- inst_info (FamInstDecl d) = case countATDecl d of
+ inst_info (FamInstD d) = case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
- inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
+ inst_info (ClsInstD _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
@@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(map (count_bind.unLoc) (bagToList inst_meths))),
ss, is, tyDecl, dtDecl)
where
- countATDecl (TyData {}) = (0, 1)
- countATDecl (TySynonym {}) = (1, 0)
- countATDecl d = pprPanic "countATDecl: Unhandled decl"
- (ppr d)
+ countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1)
+ countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a3774957a8..66cd84b6ee 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -617,7 +617,7 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% mkTySynonym (comb2 $1 $4) False $2 $4 }
+ {% mkTySynonym (comb2 $1 $4) $2 $4 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
@@ -627,7 +627,7 @@ ty_decl :: { LTyClDecl RdrName }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
- {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3
+ {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
@@ -636,7 +636,7 @@ ty_decl :: { LTyClDecl RdrName }
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
- {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3
+ {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
@@ -647,29 +647,29 @@ ty_decl :: { LTyClDecl RdrName }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
- { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
- in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
+ { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
+ in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
- ; return (L loc (FamInstDecl d)) } }
+ {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
+ ; return (L loc (FamInstD d)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
- {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3
+ {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
- ; return (L loc (FamInstDecl d)) } }
+ ; return (L loc (FamInstD d)) } }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
gadt_constrlist
deriving
- {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3
+ {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
- ; return (L loc (FamInstDecl d)) } }
+ ; return (L loc (FamInstD d)) } }
-- Associated type family declarations
--
@@ -680,43 +680,45 @@ inst_decl :: { LInstDecl RdrName }
-- declarations without a kind signature cause parsing conflicts with empty
-- data declarations.
--
-at_decl_cls :: { LTyClDecl RdrName }
- -- type family declarations
+at_decl_cls :: { LHsDecl RdrName }
+ -- family declarations
: 'type' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared.
- {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
+ {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
+ ; return (L loc (TyClD decl)) } }
+
+ | 'data' type opt_kind_sig
+ {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
+ ; return (L loc (TyClD decl)) } }
-- default type instance
| 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% mkTySynonym (comb2 $1 $4) True $2 $4 }
-
- -- data/newtype family declaration
- | 'data' type opt_kind_sig
- {% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) }
+ {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
+ ; return (L loc (InstD (FamInstD fid))) } }
-- Associated type instances
--
-at_decl_inst :: { LTyClDecl RdrName }
+at_decl_inst :: { LFamInstDecl RdrName }
-- type instance declarations
: 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% mkTySynonym (comb2 $1 $4) True $2 $4 }
+ {% mkFamInstSynonym (comb2 $1 $4) $2 $4 }
-- data/newtype instance declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
- {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3
- Nothing (reverse (unLoc $4)) (unLoc $5) }
+ {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
+ Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
- {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3
- (unLoc $4) (unLoc $5) (unLoc $6) }
+ {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
+ (unLoc $4) (unLoc $5) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
@@ -755,7 +757,7 @@ stand_alone_deriving :: { LDerivDecl RdrName }
-- Declaration in class bodies
--
decl_cls :: { Located (OrdList (LHsDecl RdrName)) }
-decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+decl_cls : at_decl_cls { LL (unitOL $1) }
| decl { $1 }
-- A 'default' signature used with the generic-programming extension
@@ -786,7 +788,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
-decl_inst : at_decl_inst { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 4311c2522d..70a0e886f1 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -127,18 +127,18 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
- { TyData { tcdND = DataType, tcdCtxt = noLoc []
- , tcdLName = noLoc (ifaceExtRdrName $2)
- , tcdTyVars = map toHsTvBndr $3
- , tcdTyPats = Nothing, tcdKindSig = Nothing
- , tcdCons = $6, tcdDerivs = Nothing } }
+ { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
+ , tcdTyVars = map toHsTvBndr $3
+ , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc []
+ , td_kindSig = Nothing
+ , td_cons = $6, td_derivs = Nothing } } }
| '%newtype' q_tc_name tv_bndrs trep ';'
- { let tc_rdr = ifaceExtRdrName $2 in
- TyData { tcdND = NewType, tcdCtxt = noLoc []
- , tcdLName = noLoc tc_rdr
- , tcdTyVars = map toHsTvBndr $3
- , tcdTyPats = Nothing, tcdKindSig = Nothing
- , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } }
+ { let tc_rdr = ifaceExtRdrName $2 in
+ TyDecl { tcdLName = noLoc tc_rdr
+ , tcdTyVars = map toHsTvBndr $3
+ , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
+ , td_kindSig = Nothing
+ , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 72fe1a2898..9111475ee2 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -5,13 +5,16 @@ Functions over HsSyn specialised to RdrName.
\begin{code}
module RdrHsSyn (
- extractHsTyRdrTyVars,
- extractHsRhoRdrTyVars, extractGenericPatTyVars,
+ extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+ extractGenericPatTyVars,
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice, mkTopSpliceDecl,
- mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
+ mkClassDecl,
+ mkTyData, mkFamInstData,
+ mkTySynonym, mkFamInstSynonym,
+ mkTyFamily,
splitCon, mkInlinePragma,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -34,7 +37,6 @@ module RdrHsSyn (
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkTyVars, -- [LHsType RdrName] -> P ()
- checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkPattern, -- HsExp -> P HsPat
bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -72,7 +74,7 @@ import Maybes
import Control.Applicative ((<$>))
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
-import Data.List ( nubBy, partition )
+import Data.List ( nubBy )
import Data.Char
#include "HsVersions.h"
@@ -95,12 +97,6 @@ extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
-extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
--- This one takes the context and tau-part of a
--- sigma type and returns their free type variables
-extractHsRhoRdrTyVars ctxt ty
- = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
-
extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName]
extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
@@ -179,49 +175,77 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl RdrName)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
- = do { let (binds, sigs, at_stuff, docs) = cvBindsAndSigs (unLoc where_cls)
- (at_defs, ats) = partition (isTypeDecl . unLoc) at_stuff
+ = do { let (binds, sigs, ats, at_defs, docs) = cvBindsAndSigs (unLoc where_cls)
cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed
- ; checkKindSigs ats
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
- -> Bool -- True <=> data family instance
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (HsBndrSig (LHsKind RdrName))
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
-mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
+ ; tyvars <- checkTyVars tycl_hdr tparams
+ ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+ ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
+ tcdTyDefn = defn, tcdFVs = placeHolderNames })) }
- ; checkDatatypeContext mcxt
+mkFamInstData :: SrcSpan
+ -> NewOrData
+ -> Maybe CType
+ -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
+ -> Maybe (HsBndrSig (LHsKind RdrName))
+ -> [LConDecl RdrName]
+ -> Maybe [LHsType RdrName]
+ -> P (LFamInstDecl RdrName)
+mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+ = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+ ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+ ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+ , fid_defn = defn })) }
+
+mkDataDefn :: NewOrData
+ -> Maybe CType
+ -> Maybe (LHsContext RdrName)
+ -> Maybe (HsBndrSig (LHsKind RdrName))
+ -> [LConDecl RdrName]
+ -> Maybe [LHsType RdrName]
+ -> P (HsTyDefn RdrName)
+mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+ = do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
- ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
- ; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType,
- tcdCtxt = cxt, tcdLName = tc,
- tcdTyVars = tyvars, tcdTyPats = typats,
- tcdCons = data_cons,
- tcdKindSig = ksig,
- tcdDerivs = maybe_deriv })) }
+ ; return (TyData { td_ND = new_or_data, td_cType = cType
+ , td_ctxt = cxt
+ , td_cons = data_cons
+ , td_kindSig = ksig
+ , td_derivs = maybe_deriv }) }
mkTySynonym :: SrcSpan
- -> Bool -- True <=> type family instances
-> LHsType RdrName -- LHS
-> LHsType RdrName -- RHS
-> P (LTyClDecl RdrName)
-mkTySynonym loc is_family lhs rhs
+mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
- ; (tyvars, typats) <- checkTParams is_family lhs tparams
- ; return (L loc (TySynonym { tcdLName = tc
- , tcdTyVars = tyvars, tcdTyPats = typats
- , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) }
+ ; tyvars <- checkTyVars lhs tparams
+ ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
+ tcdTyDefn = TySynonym rhs, tcdFVs = placeHolderNames })) }
+
+mkFamInstSynonym :: SrcSpan
+ -> LHsType RdrName -- LHS
+ -> LHsType RdrName -- RHS
+ -> P (LFamInstDecl RdrName)
+mkFamInstSynonym loc lhs rhs
+ = do { (tc, tparams) <- checkTyClHdr lhs
+ ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+ , fid_defn = TySynonym rhs })) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
@@ -271,27 +295,31 @@ cvTopDecls decls = go (fromOL decls)
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
- ValBindsIn mbs sigs
+ (mbs, sigs, fam_ds, fam_insts, _)
+ -> ASSERT( null fam_ds && null fam_insts )
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
+ -> (Bag ( LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]
+ , [LFamInstDecl RdrName], [LDocDecl])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [], [], [])
- go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
- where (bs, ss, ts, docs) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
+ go [] = (emptyBag, [], [], [], [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts, fis, docs)
+ where (bs, ss, ts, fis, docs) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, fis, docs)
where (b', ds') = getMonoBind (L l b) ds
- (bs, ss, ts, docs) = go ds'
- go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
- where (bs, ss, ts, docs) = go ds
- go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
- where (bs, ss, ts, docs) = go ds
- go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
+ (bs, ss, ts, fis, docs) = go ds'
+ go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs)
+ where (bs, ss, ts, fis, docs) = go ds
+ go (L l (InstD (FamInstD fi)) : ds) = (bs, ss, ts, L l fi : fis, docs)
+ where (bs, ss, ts, fis, docs) = go ds
+ go (L l (DocD d) : ds) = (bs, ss, ts, fis, (L l d) : docs)
+ where (bs, ss, ts, fis, docs) = go ds
+ go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
@@ -465,33 +493,6 @@ we can bring x,y into scope. So:
* For RecCon we do not
\begin{code}
-checkTParams :: Bool -- Type/data family
- -> LHsType RdrName
- -> [LHsType RdrName]
- -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
--- checkTParams checks the type parameters of a data/newtype declaration
--- There are two cases:
---
--- a) Vanilla data/newtype decl. In that case
--- - the type parameters should all be type variables
--- - they may have a kind annotation
---
--- b) Family data/newtype decl. In that case
--- - The type parameters may be arbitrary types
--- - We find the type-varaible binders by find the
--- free type vars of those types
--- - We make them all kind-sig-free binders (UserTyVar)
--- If there are kind sigs in the type parameters, they
--- will fix the binder's kind when we kind-check the
--- type parameters
-checkTParams is_family tycl_hdr tparams
- | not is_family -- Vanilla case (a)
- = do { tyvars <- checkTyVars tycl_hdr tparams
- ; return (tyvars, Nothing) }
- | otherwise -- Family case (b)
- = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
- ; return (tyvars, Just tparams) }
-
checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False',
@@ -502,7 +503,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs)))
+ | isRdrTyVar tv = return (L l (KindedTyVar tv (mkHsBSig k)))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk t@(L l _)
@@ -551,18 +552,6 @@ checkTyClHdr ty
-- See Note [Unit tuples] in HsTypes
go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
--- Check that associated type declarations of a class are all kind signatures.
---
-checkKindSigs :: [LTyClDecl RdrName] -> P ()
-checkKindSigs = mapM_ check
- where
- check (L l tydecl)
- | isFamilyDecl tydecl = return ()
- | isTypeDecl tydecl = return ()
- | otherwise
- = parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:"
- $$ ppr tydecl)
-
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l orig_t)
= check orig_t
@@ -639,7 +628,7 @@ checkAPat dynflags loc e0 = case e0 of
let t' = case t of
L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
other -> other
- return (SigPatIn e (HsBSig t' placeHolderBndrs))
+ return (SigPatIn e (mkHsBSig t'))
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index f1adba6bd3..66c40928a2 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -22,7 +22,7 @@ module RnEnv (
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
- lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName,
+ lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
@@ -272,22 +272,13 @@ lookupInstDeclBndr cls what rdr
-----------------------------------------------
-lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
--- Used for TyData and TySynonym only,
--- both ordinary ones and family instances
+lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)
+-- Used for TyData and TySynonym family instances only,
-- See Note [Family instance binders]
-lookupTcdName mb_cls tc_decl
- | not (isFamInstDecl tc_decl) -- The normal case
- = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
- lookupLocatedTopBndrRn tc_rdr
-
- | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
+lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind
= wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
-
- | otherwise -- Family instance; tc_rdr is an *occurrence*
+lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence*
= lookupLocatedOccRn tc_rdr
- where
- tc_rdr = tcdLName tc_decl
-----------------------------------------------
lookupConstructorFields :: Name -> RnM [Name]
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 553c3ef81a..ee4bcfce96 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -529,10 +529,10 @@ getLocalNonValBinders fixity_env
; return (AvailTC main_name names) }
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
- new_assoc (L _ (FamInstDecl d))
+ new_assoc (L _ (FamInstD d))
= do { avail <- new_ti Nothing d
; return [avail] }
- new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
+ new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
| Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
; mapM (new_ti (Just cls_nm) . unLoc) ats }
@@ -542,9 +542,8 @@ getLocalNonValBinders fixity_env
new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
new_ti mb_cls ti_decl -- ONLY for type/data instances
- = ASSERT( isFamInstDecl ti_decl )
- do { main_name <- lookupTcdName mb_cls ti_decl
- ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
+ = do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl)
+ ; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl)
; return (AvailTC (unLoc main_name) sub_names) }
-- main_name is not bound here!
\end{code}
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index a4a734cca1..d545b7ca38 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -24,7 +24,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
import HsSyn
import RdrName
-import RdrHsSyn ( extractHsRhoRdrTyVars )
+import RdrHsSyn ( extractHsTysRdrTyVars )
import RnTypes
import RnBinds
import RnEnv
@@ -423,11 +423,12 @@ patchCCallTarget packageId callTarget
\begin{code}
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (FamInstDecl ty_decl)
- = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl
- ; return (FamInstDecl ty_decl', fvs) }
+rnSrcInstDecl (FamInstD fi)
+ = do { (fi', fvs) <- rnFamInstDecl Nothing fi
+ ; return (FamInstD fi', fvs) }
-rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
+rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
+ , cid_sigs = uprags, cid_fam_insts = ats })
-- Used for both source and interface file decls
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
@@ -438,7 +439,7 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
-- Both need to have the instance type variables in scope
; ((ats', other_sigs'), more_fvs)
<- extendTyVarEnvFVRn tv_names $
- do { (ats', at_fvs) <- rnATDecls cls tv_names ats
+ do { (ats', at_fvs) <- rnATInstDecls cls tv_names ats
; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
; return ( (ats', other_sigs')
, at_fvs `plusFV` sig_fvs) }
@@ -462,7 +463,8 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
<- renameSigs (InstDeclCtxt cls) spec_inst_prags
; let uprags' = spec_inst_prags' ++ other_sigs'
- ; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
+ ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
+ , cid_sigs = uprags', cid_fam_insts = ats' },
meth_fvs `plusFV` more_fvs
`plusFV` spec_inst_fvs
`plusFV` inst_fvs) }
@@ -476,23 +478,45 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
-- the instance context after renaming. This is a bit
-- strange, but should not matter (and it would be more work
-- to remove the context).
+
+rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
+rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
+ = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
+ ; tv_names <- mkTyVarBndrNames mb_cls (extractHsTysRdrTyVars pats)
+ -- All the free vars of the family patterns
+ ; bindLocalNamesFV tv_names $
+ do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
+ ; (defn', rhs_fvs) <- rnTyDefn tycon defn
+
+ -- See Note [Renaming associated types]
+ ; let bad_tvs = case mb_cls of
+ Nothing -> []
+ Just (_,cls_tvs) -> filter is_bad cls_tvs
+ is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
+ ; unless (null bad_tvs) (badAssocRhs bad_tvs)
+
+ ; return ( FamInstDecl { fid_tycon = tycon'
+ , fid_pats = HsBSig pats' tv_names
+ , fid_defn = defn' }
+ , (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon') } }
+ -- type instance => use, hence addOneFV
\end{code}
Renaming of the associated types in instances.
\begin{code}
-rnATDecls :: Name -- Class
- -> [Name] -- Type variable binders (but NOT kind variables)
+rnATInstDecls :: Name -- Class
+ -> [Name] -- Type variable binders (but NOT kind variables)
-- See Note [Renaming associated types] in RnTypes
- -> [LTyClDecl RdrName]
- -> RnM ([LTyClDecl Name], FreeVars)
+ -> [LFamInstDecl RdrName]
+ -> RnM ([LFamInstDecl Name], FreeVars)
-- Used for the family declarations and defaults in a class decl
-- and the family instance declarations in an instance
--
-- NB: We allow duplicate associated-type decls;
-- See Note [Associated type instances] in TcInstDcls
-rnATDecls cls tvs atDecls
- = rnList (rnTyClDecl (Just (cls, tvs))) atDecls
+rnATInstDecls cls tvs atDecls
+ = rnList (rnFamInstDecl (Just (cls, tvs))) atDecls
\end{code}
For the method bindings in class and instance decls, we extend the
@@ -797,79 +821,27 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
-- in a class decl
rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
, tcdFlavour = flav, tcdKindSig = kind })
- = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' ->
+ = do { let tv_rdr_names = hsLTyVarLocNames tyvars
+ ; checkDupRdrNames tv_rdr_names -- Check for duplicated bindings
+ ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names
+ ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFlavour = flav, tcdKindSig = kind' }
- , fv_kind) }
+ , fv_kind) } }
where
fmly_doc = TyFamilyCtx tycon
--- "data", "newtype", "data instance, and "newtype instance" declarations
+-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
-rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
- tcdCtxt = context,
- tcdLName = tycon, tcdTyVars = tyvars,
- tcdTyPats = typats, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs}
- = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' ->
- -- Checks for distinct tyvars
- do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl
- ; checkTc (h98_style || null (unLoc context))
- (badGadtStupidTheta tycon)
-
- ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig
- ; (context', fvs1) <- rnContext data_doc context
- ; (typats', fvs2) <- rnTyPats data_doc tycon' typats
- ; (derivs', fvs3) <- rn_derivs derivs
-
- -- For the constructor declarations, drop the LocalRdrEnv
- -- in the GADT case, where the type variables in the declaration
- -- do not scope over the constructor signatures
- -- data T a where { T1 :: forall b. b-> b }
- ; let { zap_lcl_env | h98_style = \ thing -> thing
- | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
- ; (condecls', con_fvs) <- zap_lcl_env $
- rnConDecls condecls
- -- No need to check for duplicate constructor decls
- -- since that is done by RnNames.extendGlobalRdrEnvRn
-
- ; return ( TyData { tcdND = new_or_data, tcdCType = cType
- , tcdCtxt = context'
- , tcdLName = tycon', tcdTyVars = tyvars'
- , tcdTyPats = typats', tcdKindSig = sig'
- , tcdCons = condecls', tcdDerivs = derivs'}
- , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV`
- con_fvs `plusFV` sig_fvs )
- }
- where
- h98_style = case condecls of -- Note [Stupid theta]
- L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
- _ -> True
-
- data_doc = TyDataCtx tycon
-
- rn_derivs Nothing = return (Nothing, emptyFVs)
- rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
- ; return (Just ds', fvs) }
-
--- "type" and "type instance" declarations
-rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars
- , tcdLName = name
- , tcdTyPats = typats, tcdSynRhs = ty})
- = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl
- ; ((tyvars', typats', ty'), fvs)
- <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do
- do { (typats',fvs1) <- rnTyPats syn_doc name' typats
- ; (ty', fvs2) <- rnLHsType syn_doc ty
- ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) }
- ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
- , tcdTyPats = typats', tcdSynRhs = ty'
- , tcdFVs = fvs }
- , fvs) }
- where
- syn_doc = TySynCtx name
+rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+ = do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' ->
+ do { (defn', fvs) <- rnTyDefn tycon defn
+ ; return ((tyvars', defn'), fvs) }
+ ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
+ , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
@@ -886,8 +858,8 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
; fds' <- rnFds (docOfHsDocContext cls_doc) fds
-- The fundeps have no free variables
; let tv_ns = hsLTyVarNames tyvars'
- ; (ats', fv_ats) <- rnATDecls cls' tv_ns ats
- ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs
+ ; (ats', fv_ats) <- rnList (rnTyClDecl (Just (cls', tv_ns))) ats
+ ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tv_ns at_defs
; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
; let fvs = cxt_fvs `plusFV`
sig_fvs `plusFV`
@@ -934,6 +906,52 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
cls_doc = ClassDeclCtx lcls
+rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars)
+rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
+ , td_ctxt = context, td_cons = condecls
+ , td_kindSig = sig, td_derivs = derivs })
+ = do { checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta tycon)
+
+ ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig
+ ; (context', fvs1) <- rnContext data_doc context
+ ; (derivs', fvs3) <- rn_derivs derivs
+
+ -- For the constructor declarations, drop the LocalRdrEnv
+ -- in the GADT case, where the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; let { zap_lcl_env | h98_style = \ thing -> thing
+ | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
+ ; (condecls', con_fvs) <- zap_lcl_env $
+ rnConDecls condecls
+ -- No need to check for duplicate constructor decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+ ; return ( TyData { td_ND = new_or_data, td_cType = cType
+ , td_ctxt = context', td_kindSig = sig'
+ , td_cons = condecls', td_derivs = derivs'}
+ , fvs1 `plusFV` fvs3 `plusFV`
+ con_fvs `plusFV` sig_fvs )
+ }
+ where
+ h98_style = case condecls of -- Note [Stupid theta]
+ L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
+ _ -> True
+
+ data_doc = TyDataCtx tycon
+
+ rn_derivs Nothing = return (Nothing, emptyFVs)
+ rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
+ ; return (Just ds', fvs) }
+
+-- "type" and "type instance" declarations
+rnTyDefn tycon (TySynonym { td_synRhs = ty })
+ = do { (ty', rhs_fvs) <- rnLHsType syn_doc ty
+ ; return (TySynonym { td_synRhs = ty' }, rhs_fvs) }
+ where
+ syn_doc = TySynCtx tycon
+
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
= vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
@@ -973,10 +991,10 @@ depAnalTyClDecls ds_w_fvs
, tcdATs = ats } -> do
L _ assoc_decl <- ats
return (tcdName assoc_decl, cls_name)
- TyData { tcdLName = L _ data_name
- , tcdCons = cons } -> do
- L _ dc <- cons
- return (unLoc (con_name dc), data_name)
+ TyDecl { tcdLName = L _ data_name
+ , tcdTyDefn = TyData { td_cons = cons } }
+ -> do L _ dc <- cons
+ return (unLoc (con_name dc), data_name)
_ -> []
\end{code}
@@ -1001,24 +1019,36 @@ is jolly confusing. See Trac #4875
%*********************************************************
\begin{code}
-rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName]
- -> RnM (Maybe [LHsType Name], FreeVars)
--- Although, we are processing type patterns here, all type variables will
--- already be in scope (they are the same as in the 'tcdTyVars' field of the
--- type declaration to which these patterns belong)
-rnTyPats _ _ Nothing
- = return (Nothing, emptyFVs)
-rnTyPats doc tc (Just typats)
- = do { (typats', fvs) <- rnLHsTypes doc typats
- ; return (Just typats', addOneFV fvs (unLoc tc)) }
- -- type instance => use, hence addOneFV
-
+---------------
+mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name]
+mkTyVarBndrNames Nothing tv_rdr_names
+ = newLocalBndrsRn tv_rdr_names
+mkTyVarBndrNames (Just _) tv_rdr_names
+ = do { rdr_env <- getLocalRdrEnv
+ ; let mk_tv_name :: Located RdrName -> RnM Name
+ -- Use the same Name as the parent class decl
+ mk_tv_name (L l tv_rdr)
+ = case lookupLocalRdrEnv rdr_env tv_rdr of
+ Just n -> return n
+ Nothing -> newLocalBndrRn (L l tv_rdr)
+
+ ; mapM mk_tv_name tv_rdr_names }
+
+---------------
+badAssocRhs :: [Name] -> RnM ()
+badAssocRhs ns
+ = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
+ <> plural ns
+ <+> pprWithCommas (quotes . ppr) ns)
+ 2 (ptext (sLit "All such variables must be bound on the LHS")))
+
+-----------------
rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
- , con_cxt = cxt, con_details = details
+ , con_cxt = lcxt@(L _ cxt), con_details = details
, con_res = res_ty, con_doc = mb_doc
, con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
@@ -1045,7 +1075,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
; mb_doc' <- rnMbLHsDoc mb_doc
; bindHsTyVars doc new_tvs $ \new_tyvars -> do
- { (new_context, fvs1) <- rnContext doc cxt
+ { (new_context, fvs1) <- rnContext doc lcxt
; (new_details, fvs2) <- rnConDeclDetails doc details
; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
@@ -1053,7 +1083,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
where
doc = ConDeclCtx name
- get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys))
+ get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
rnConResult :: HsDocContext -> Name
-> HsConDetails (LHsType Name) [ConDeclField Name]
@@ -1171,10 +1201,10 @@ extendRecordFieldEnv tycl_decls inst_decls
; return $ unLoc x'}
all_data_cons :: [ConDecl RdrName]
- all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
+ all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs
, L _ con <- cons ]
- all_tycl_decls = at_tycl_decls ++ concat tycl_decls
- at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types!
+ all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ]
+ ++ map fid_defn (instDeclFamInsts inst_decls) -- Do not forget associated types!
get_con (ConDecl { con_name = con, con_details = RecCon flds })
(RecFields env fld_set)
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 28ac999f43..04a7fad19b 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -26,7 +26,7 @@ module RnTypes (
rnSplice, checkTH,
-- Binding related stuff
- bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig
+ bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -36,7 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
import DynFlags
import HsSyn
-import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars )
+import RdrHsSyn ( extractHsTyRdrTyVars, extractHsTysRdrTyVars )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
@@ -121,14 +121,14 @@ rnHsKind = rnHsTyKi False
rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty)
+rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
= ASSERT ( isType ) do
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
name_env <- getLocalRdrEnv
let
- mentioned = extractHsRhoRdrTyVars ctxt ty
+ mentioned = extractHsTysRdrTyVars (ty:ctxt)
-- Don't quantify over type variables that are in scope;
-- when GlasgowExts is off, there usually won't be any, except for
@@ -137,17 +137,17 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty)
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
tyvar_bndrs = userHsTyVarBndrs forall_tyvars
- rnForAll doc Implicit tyvar_bndrs ctxt ty
+ rnForAll doc Implicit tyvar_bndrs lctxt ty
-rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
+rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
= ASSERT ( isType ) do { -- Explicit quantification.
-- Check that the forall'd tyvars are actually
-- mentioned in the type, and produce a warning if not
- let mentioned = extractHsRhoRdrTyVars ctxt tau
+ let mentioned = extractHsTysRdrTyVars (tau:ctxt)
in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
- ; rnForAll doc Explicit forall_tyvars ctxt tau }
+ ; rnForAll doc Explicit forall_tyvars lctxt tau }
rnHsTyKi isType _ (HsTyVar rdr_name)
= do { name <- rnTyVar isType rdr_name
@@ -331,56 +331,6 @@ bindSigTyVarsFV tvs thing_inside
bindLocalNamesFV tvs thing_inside }
---------------
-bindTyClTyVars
- :: HsDocContext
- -> Maybe (Name, [Name]) -- Parent class and its tyvars
- -- (but not kind vars)
- -> [LHsTyVarBndr RdrName]
- -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
--- Used for tyvar binders in type/class declarations
--- Just like bindHsTyVars, but deals with the case of associated
--- types, where the type variables may be already in scope
-bindTyClTyVars doc mb_cls tyvars thing_inside
- | Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance
- = do { let tv_rdr_names = map hsLTyVarLocName tyvars
- -- *All* the free vars of the family patterns
-
- -- Check for duplicated bindings
- -- This test is irrelevant for data/type *instances*, where the tyvars
- -- are the free tyvars of the patterns, and hence have no duplicates
- -- But it's needed for data/type *family* decls
- ; checkDupRdrNames tv_rdr_names
-
- -- Make the Names for the tyvars
- ; rdr_env <- getLocalRdrEnv
- ; let mk_tv_name :: Located RdrName -> RnM Name
- -- Use the same Name as the parent class decl
- mk_tv_name (L l tv_rdr)
- = case lookupLocalRdrEnv rdr_env tv_rdr of
- Just n -> return n
- Nothing -> newLocalBndrRn (L l tv_rdr)
- ; tv_ns <- mapM mk_tv_name tv_rdr_names
-
- ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside
-
- -- See Note [Renaming associated types]
- ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs
- ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
-
- ; return (thing, fvs) }
-
- | otherwise -- Not associated, just fall through to bindHsTyVars
- = bindHsTyVars doc tyvars thing_inside
-
-badAssocRhs :: [Name] -> RnM ()
-badAssocRhs ns
- = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
- <> plural ns
- <+> pprWithCommas (quotes . ppr) ns)
- 2 (ptext (sLit "All such variables must be bound on the LHS")))
-
----------------
bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index f2f6059cee..b9711576c4 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -404,18 +404,7 @@ tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
= addErrCtxt ctxt thing_inside
where
- thing | isClassDecl decl = "class"
- | isTypeDecl decl = "type synonym" ++ maybeInst
- | isDataDecl decl = if tcdND decl == NewType
- then "newtype" ++ maybeInst
- else "data type" ++ maybeInst
- | isFamilyDecl decl = "family"
- | otherwise = panic "tcAddDeclCtxt/thing"
-
- maybeInst | isFamInstDecl decl = " instance"
- | otherwise = ""
-
- ctxt = hsep [ptext (sLit "In the"), text thing,
+ ctxt = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
badMethodErr :: Outputable a => a -> Name -> SDoc
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index e8691a4996..572b2a2dc4 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -23,7 +23,7 @@ import DynFlags
import TcRnMonad
import FamInst
import TcEnv
-import TcTyClsDecls( tcFamTyPats )
+import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt )
import TcClassDcl( tcAddDeclCtxt ) -- Small helper
import TcGenDeriv -- Deriv stuff
import TcGenGenerics
@@ -447,27 +447,58 @@ makeDerivSpecs :: Bool
-> [LDerivDecl Name]
-> TcM [EarlyDerivSpec]
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
- | is_boot -- No 'deriving' at all in hs-boot files
- = do { mapM_ add_deriv_err deriv_locs
- ; return [] }
- | otherwise
- = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
- ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
- ; return (eqns1 ++ eqns2) }
+ = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls
+ ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
+ ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
+ ; let eqns = eqns1 ++ eqns2 ++ eqns3
+ ; if is_boot then -- No 'deriving' at all in hs-boot files
+ do { unless (null eqns) (add_deriv_err (head eqns))
+ ; return [] }
+ else return eqns }
where
- extractTyDataPreds decls
- = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+ add_deriv_err eqn
+ = setSrcSpan loc $
+ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+ 2 (ptext (sLit "Use an instance declaration instead")))
+ where
+ loc = case eqn of { Left ds -> ds_loc ds; Right ds -> ds_loc ds }
- all_tydata :: [(LHsType Name, LTyClDecl Name)]
- -- Derived predicate paired with its data type declaration
- all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls)
+------------------------------------------------------------------
+deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
+deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name
+ , tcdTyDefn = TyData { td_derivs = Just preds } }))
+ = tcAddDeclCtxt decl $
+ do { tc <- tcLookupTyCon tc_name
+ ; let tvs = tyConTyVars tc
+ tys = mkTyVarTys tvs
+ ; mapM (deriveTyData tvs tc tys) preds }
- deriv_locs = map (getLoc . snd) all_tydata
- ++ map getLoc deriv_decls
+deriveTyDecl _ = return []
- add_deriv_err loc = setSrcSpan loc $
- addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
- 2 (ptext (sLit "Use an instance declaration instead")))
+------------------------------------------------------------------
+deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
+deriveInstDecl (L _ (FamInstD fam_inst))
+ = deriveFamInst fam_inst
+deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
+ = concatMapM (deriveFamInst . unLoc) fam_insts
+
+------------------------------------------------------------------
+deriveFamInst :: FamInstDecl Name -> TcM [EarlyDerivSpec]
+deriveFamInst decl@(FamInstDecl { fid_tycon = L _ tc_name, fid_pats = pats
+ , fid_defn = TyData { td_derivs = Just preds } })
+ = tcAddFamInstCtxt decl $
+ do { fam_tc <- tcLookupTyCon tc_name
+ ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ ->
+ mapM (deriveTyData tvs' fam_tc pats') preds }
+ -- Tiresomely we must figure out the "lhs", which is awkward for type families
+ -- E.g. data T a b = .. deriving( Eq )
+ -- Here, the lhs is (T a b)
+ -- data instance TF Int b = ... deriving( Eq )
+ -- Here, the lhs is (TF Int b)
+ -- But if we just look up the tycon_name, we get is the *family*
+ -- tycon, but not pattern types -- they are in the *rep* tycon.
+
+deriveFamInst _ = return []
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
@@ -496,16 +527,14 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
(Just theta) }
------------------------------------------------------------------
-deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
+deriveTyData :: [TyVar] -> TyCon -> [Type]
+ -> LHsType Name -- The deriving predicate
+ -> TcM EarlyDerivSpec
-- The deriving clause of a data or newtype declaration
-deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
- tcdTyVars = hs_tvs,
- tcdTyPats = ty_pats }))
+deriveTyData tvs tc tc_args (L loc deriv_pred)
= setSrcSpan loc $ -- Use the location of the 'deriving' item
- tcAddDeclCtxt decl $
- do { (tvs, tc, tc_args) <- get_lhs ty_pats
- ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
- -- the type variables for the type constructor
+ tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
+ -- the type variables for the type constructor
do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
-- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -525,7 +554,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
`minusVarSet` dropped_tvs
- ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
+ ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$
+ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
-- Check that the result really is well-kinded
; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
@@ -547,25 +577,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
(typeFamilyPapErr tc cls cls_tys inst_ty)
- ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
- where
- -- Tiresomely we must figure out the "lhs", which is awkward for type families
- -- E.g. data T a b = .. deriving( Eq )
- -- Here, the lhs is (T a b)
- -- data instance TF Int b = ... deriving( Eq )
- -- Here, the lhs is (TF Int b)
- -- But if we just look up the tycon_name, we get is the *family*
- -- tycon, but not pattern types -- they are in the *rep* tycon.
- get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
- ; let tvs = tyConTyVars tc
- ; return (tvs, tc, mkTyVarTys tvs) }
- get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name
- ; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $
- \ tvs' pats' _ ->
- return (tvs', fam_tc, pats') }
-
-deriveTyData _other
- = panic "derivTyData" -- Caller ensures that only TyData can happen
+ ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
\end{code}
Note [Deriving, type families, and partial applications]
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 229fed36b6..64b839c83f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -443,13 +443,14 @@ tcLocalInstDecl1 :: LInstDecl Name
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
-tcLocalInstDecl1 (L loc (FamInstDecl decl))
+tcLocalInstDecl1 (L loc (FamInstD decl))
= setSrcSpan loc $
- tcAddDeclCtxt decl $
+ tcAddFamInstCtxt decl $
do { fam_inst <- tcFamInstDecl TopLevel decl
; return ([], [fam_inst]) }
-tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
+tcLocalInstDecl1 (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
+ , cid_sigs = uprags, cid_fam_insts = ats }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
@@ -468,7 +469,7 @@ tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
-- Check for missing associated types and build them
-- from their defaults (if available)
- ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
+ ; let defined_ats = mkNameSet $ map famInstDeclName ats
mk_deflt_at_instances :: ClassATItem -> TcM [FamInst]
mk_deflt_at_instances (fam_tc, defs)
@@ -522,12 +523,12 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
-tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst
+tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst
tcFamInstDecl top_lvl decl
= do { -- Type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
; traceTc "tcFamInstDecl" (ppr decl)
- ; let fam_tc_lname = tcdLName decl
+ ; let fam_tc_lname = fid_tycon decl
; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl fam_tc_lname
@@ -544,10 +545,11 @@ tcFamInstDecl top_lvl decl
-- This is where type and data decls are treated separately
; tcFamInstDecl1 fam_tc decl }
-tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst
+tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst
-- "type instance"
-tcFamInstDecl1 fam_tc (decl@TySynonym {})
+tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name
+ , fid_defn = TySynonym {} })
= do { -- (1) do the work of verifying the synonym
; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl
@@ -555,21 +557,22 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
; checkValidFamInst t_typats t_rhs
-- (3) construct representation tycon
- ; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats
+ ; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats
; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
-- "newtype instance" and "data instance"
-tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
- , tcdCtxt = ctxt
- , tcdTyVars = tvs, tcdTyPats = Just pats
- , tcdCons = cons})
+tcFamInstDecl1 fam_tc
+ (FamInstDecl { fid_pats = pats
+ , fid_tycon = fam_tc_name
+ , fid_defn = defn@TyData { td_ND = new_or_data, td_cType = cType
+ , td_ctxt = ctxt, td_cons = cons } })
= do { -- Check that the family declaration is for the right kind
checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns
- ; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $
+ ; tcFamTyPats fam_tc pats (kcTyDefn defn) $
\tvs' pats' res_kind -> do
-- Check that left-hand side contains no type family applications
@@ -581,10 +584,10 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
; stupid_theta <- tcHsContext ctxt
- ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
+ ; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
-- Construct representation tycon
- ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats'
+ ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc
; let ex_ok = True -- Existentials ok for type families!
orig_res_ty = mkTyConApp fam_tc pats'
@@ -615,17 +618,15 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
_ -> True
-tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)
-
----------------
-tcAssocDecl :: Class -- ^ Class of associated type
- -> VarEnv Type -- ^ Instantiation of class TyVars
- -> LTyClDecl Name -- ^ RHS
+tcAssocDecl :: Class -- ^ Class of associated type
+ -> VarEnv Type -- ^ Instantiation of class TyVars
+ -> LFamInstDecl Name -- ^ RHS
-> TcM FamInst
tcAssocDecl clas mini_env (L loc decl)
= setSrcSpan loc $
- tcAddDeclCtxt decl $
+ tcAddFamInstCtxt decl $
do { fam_inst <- tcFamInstDecl NotTopLevel decl
; let (fam_tc, at_tys) = famInstLHS fam_inst
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index b2b4089f54..89a018dbe3 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -18,9 +18,9 @@ module TcTyClsDecls (
-- Functions used by TcInstDcls to check
-- data/type family instance declarations
- kcDataDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
+ kcTyDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcSynFamInstDecl, tcFamTyPats,
- wrongKindOfFamily, badATErr, wrongATArgErr
+ tcAddFamInstCtxt, wrongKindOfFamily, badATErr, wrongATArgErr
) where
#include "HsVersions.h"
@@ -309,30 +309,38 @@ getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)]
--
-- ALSO for each datacon, return (dc, ANothing)
-- See Note [ANothing] in TcRnTypes
+--
+-- No family instances are passed to getInitialKinds
getInitialKinds (L _ decl)
- = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (tyClDeclTyVars decl)
+ = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (get_tvs decl)
; res_kind <- get_res_kind decl
; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind))
; inner_pairs <- get_inner_kinds decl
; return (main_pair : inner_pairs) }
where
get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)]
- get_inner_kinds (TyData { tcdCons = cons })
+ get_inner_kinds (TyDecl { tcdTyDefn = TyData { td_cons = cons } })
= return [ (unLoc (con_name con), ANothing) | L _ con <- cons ]
get_inner_kinds (ClassDecl { tcdATs = ats })
= concatMapM getInitialKinds ats
get_inner_kinds _
= return []
- get_res_kind (ClassDecl {}) = return constraintKind
- get_res_kind (TyData { tcdKindSig = Nothing }) = return liftedTypeKind
- get_res_kind _ = newMetaKindVar
+ get_res_kind (ClassDecl {}) = return constraintKind
+ get_res_kind (TyDecl { tcdTyDefn = TyData { td_kindSig = Nothing } })
+ = return liftedTypeKind
+ get_res_kind _ = newMetaKindVar
-- Warning: you might be tempted to return * for all data decls
-- but on GADT-style declarations we allow a kind signature
-- data T :: *->* where { ... }
- -- with *no tyClDeclTyVars*
+ -- with *no* tvs in the HsTyDefn
+ get_tvs (TyFamily {tcdTyVars = tvs}) = tvs
+ get_tvs (ClassDecl {tcdTyVars = tvs}) = tvs
+ get_tvs (TyDecl {tcdTyVars = tvs}) = tvs
+ get_tvs (ForeignType {}) = []
+
----------------
kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings
kcSynDecls [] = getLclEnv
@@ -349,12 +357,12 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
-- of out-of-scope tycons
kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
-kcSynDecl decl@(TySynonym { tcdTyVars = hs_tvs, tcdLName = L _ name
- , tcdSynRhs = rhs })
+kcSynDecl decl@(TyDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
+ , tcdTyDefn = TySynonym { td_synRhs = rhs } })
-- Vanilla type synonyoms only, not family instances
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
- tcHsTyVarBndrs (tcdTyVars decl) $ \ k_tvs ->
+ tcHsTyVarBndrs hs_tvs $ \ k_tvs ->
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)
<+> brackets (ppr k_tvs))
; (_, rhs_kind) <- tcLHsType rhs
@@ -365,46 +373,46 @@ kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
------------------------------------------------------------------------
kcLTyClDecl :: LTyClDecl Name -> TcM ()
+ -- See Note [Kind checking for type and class decls]
kcLTyClDecl (L loc decl)
= setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl
kcTyClDecl :: TyClDecl Name -> TcM ()
-- This function is used solely for its side effect on kind variables
-kcTyClDecl decl@(TyData { tcdLName = L _ name, tcdTyVars = hs_tvs })
- = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance
- kcTyClTyVars name hs_tvs $ \ res_k -> kcDataDecl decl res_k
+kcTyClDecl (TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = defn })
+ = kcTyClTyVars name hs_tvs $ \ res_k -> kcTyDefn defn res_k
kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
, tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
= kcTyClTyVars name hs_tvs $ \ res_k ->
do { _ <- tcHsContext ctxt
; _ <- unifyKind res_k constraintKind
- ; mapM_ (wrapLocM kcFamilyDecl) ats
- ; mapM_ (wrapLocM kc_sig) sigs }
+ ; mapM_ (wrapLocM kcTyClDecl) ats
+ ; mapM_ (wrapLocM kc_sig) sigs }
where
kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
kc_sig _ = return ()
kcTyClDecl (ForeignType {}) = return ()
-kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl decl
-kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl
- = panic "kcTyClDecl TySynonym" -- See Note [Kind checking for type and class decls]
+kcTyClDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs
+ , tcdKindSig = mb_kind})
+ = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k
-------------------
-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
-- kinded type variables are also passed as the second parameter).
---
-kcDataDecl :: TyClDecl Name -> Kind -> TcM ()
-kcDataDecl (TyData { tcdND = new_or_data, tcdCtxt = ctxt
- , tcdCons = cons, tcdKindSig = mb_kind }) res_k
+kcTyDefn :: HsTyDefn Name -> Kind -> TcM ()
+kcTyDefn (TyData { td_ND = new_or_data, td_ctxt = ctxt
+ , td_cons = cons, td_kindSig = mb_kind }) res_k
= do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM (kcConDecl new_or_data)) cons
; kcResultKind mb_kind res_k }
-kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
+kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k
+ = discardResult (tcCheckLHsType rhs_ty res_k)
-------------------
kcConDecl :: NewOrData -> ConDecl Name -> TcM ()
@@ -417,19 +425,6 @@ kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs
; _ <- tcConRes res
; return () }
--------------------
--- Kind check a family declaration or type family default declaration.
---
-kcFamilyDecl :: TyClDecl Name -> TcM ()
-kcFamilyDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs
- , tcdKindSig = mb_kind})
- = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k
-
-kcFamilyDecl (TySynonym {}) = return ()
- -- We don't have to do anything here for type family defaults:
- -- tcClassATs will use tcAssocDecl to check them
-kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d)
-
------------------
kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM ()
kcResultKind Nothing res_k
@@ -503,7 +498,7 @@ tcTyClDecl calc_isrec (L loc decl)
-- "type family" declarations
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _calc_isrec
- (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs})
+ (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs})
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "type family:" (ppr tc_name)
; checkFamFlag tc_name
@@ -523,60 +518,18 @@ tcTyClDecl1 parent _calc_isrec
; return [ATyCon tycon] }
-- "type" synonym declaration
-tcTyClDecl1 _parent _calc_isrec
- (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = hs_ty})
- = ASSERT( isNoParent _parent )
- tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
- { env <- getLclEnv
- ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
- ; rhs_ty <- tcCheckLHsType hs_ty kind
- ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
- ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty)
- kind NoParentTyCon
- ; return [ATyCon tycon] }
-
- -- "newtype" and "data"
- -- NB: not used for newtype/data instances (whether associated or not)
tcTyClDecl1 _parent calc_isrec
- (TyData { tcdND = new_or_data, tcdCType = cType
- , tcdCtxt = ctxt, tcdTyVars = tvs
- , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons })
+ (TyDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdTyDefn = defn })
+
= ASSERT( isNoParent _parent )
- tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
- { extra_tvs <- tcDataKindSig kind
- ; let is_rec = calc_isrec tc_name
- h98_syntax = consUseH98Syntax cons
- final_tvs = tvs' ++ extra_tvs
- ; stupid_theta <- tcHsContext ctxt
- ; kind_signatures <- xoptM Opt_KindSignatures
- ; existential_ok <- xoptM Opt_ExistentialQuantification
- ; gadt_ok <- xoptM Opt_GADTs
- ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
-
- -- Check that we don't use kind signatures without Glasgow extensions
- ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
-
- ; dataDeclChecks tc_name new_or_data stupid_theta cons
-
- ; tycon <- fixM $ \ tycon -> do
- { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
- ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons
- ; tc_rhs <-
- if null cons && is_boot -- In a hs-boot file, empty cons means
- then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract
- else case new_or_data of
- DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
- mkNewTyConRhs tc_name tycon (head data_cons)
- ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
- is_rec (not h98_syntax) NoParentTyCon) }
- ; return [ATyCon tycon] }
+ tcTyClTyVars tc_name tvs $ \ tvs' kind ->
+ tcTyDefn calc_isrec tc_name tvs' kind defn
tcTyClDecl1 _parent calc_isrec
(ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
- , tcdCtxt = ctxt, tcdMeths = meths
- , tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs })
+ , tcdCtxt = ctxt, tcdMeths = meths
+ , tcdFDs = fundeps, tcdSigs = sigs
+ , tcdATs = ats, tcdATDefs = at_defs })
= ASSERT( isNoParent _parent )
do
{ (tvs', ctxt', fds', sig_stuff, gen_dm_env)
@@ -628,6 +581,55 @@ tcTyClDecl1 _ _
= return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
\end{code}
+\begin{code}
+tcTyDefn :: (Name -> RecFlag) -> Name
+ -> [TyVar] -> Kind
+ -> HsTyDefn Name -> TcM [TyThing]
+ -- NB: not used for newtype/data instances (whether associated or not)
+tcTyDefn _calc_isrec tc_name tvs kind (TySynonym { td_synRhs = hs_ty })
+ = do { env <- getLclEnv
+ ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
+ ; rhs_ty <- tcCheckLHsType hs_ty kind
+ ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
+ ; tycon <- buildSynTyCon tc_name tvs (SynonymTyCon rhs_ty)
+ kind NoParentTyCon
+ ; return [ATyCon tycon] }
+
+tcTyDefn calc_isrec tc_name tvs kind
+ (TyData { td_ND = new_or_data, td_cType = cType
+ , td_ctxt = ctxt, td_kindSig = mb_ksig
+ , td_cons = cons })
+ = do { extra_tvs <- tcDataKindSig kind
+ ; let is_rec = calc_isrec tc_name
+ h98_syntax = consUseH98Syntax cons
+ final_tvs = tvs ++ extra_tvs
+ ; stupid_theta <- tcHsContext ctxt
+ ; kind_signatures <- xoptM Opt_KindSignatures
+ ; existential_ok <- xoptM Opt_ExistentialQuantification
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
+
+ -- Check that we don't use kind signatures without Glasgow extensions
+ ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
+
+ ; dataDeclChecks tc_name new_or_data stupid_theta cons
+
+ ; tycon <- fixM $ \ tycon -> do
+ { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
+ ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons
+ ; tc_rhs <-
+ if null cons && is_boot -- In a hs-boot file, empty cons means
+ then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract
+ else case new_or_data of
+ DataType -> return (mkDataTyConRhs data_cons)
+ NewType -> ASSERT( not (null data_cons) )
+ mkNewTyConRhs tc_name tycon (head data_cons)
+ ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
+ is_rec (not h98_syntax) NoParentTyCon) }
+ ; return [ATyCon tycon] }
+\end{code}
+
%************************************************************************
%* *
Typechecking associated types (in class decls)
@@ -655,21 +657,21 @@ Note that:
tcClassATs :: Name -- The class name (not knot-tied)
-> TyConParent -- The class parent of this associated type
-> [LTyClDecl Name] -- Associated types. All FamTyCon
- -> [LTyClDecl Name] -- Associated type defaults. All SynTyCon
+ -> [LFamInstDecl Name] -- Associated type defaults. All SynTyCon
-> TcM [ClassATItem]
tcClassATs class_name parent ats at_defs
= do { -- Complain about associated type defaults for non associated-types
sequence_ [ failWithTc (badATErr class_name n)
- | n <- map (tcdName . unLoc) at_defs
+ | L _ n <- map (fid_tycon . unLoc) at_defs
, not (n `elemNameSet` at_names) ]
; mapM tc_at ats }
where
at_names = mkNameSet (map (tcdName . unLoc) ats)
- at_defs_map :: NameEnv [LTyClDecl Name]
+ at_defs_map :: NameEnv [LFamInstDecl Name]
-- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
- (tcdName (unLoc at_def)) [at_def])
+ (famInstDeclName at_def) [at_def])
emptyNameEnv at_defs
tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent
@@ -679,31 +681,27 @@ tcClassATs class_name parent ats at_defs
; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs
; return (fam_tc, atd) }
-
-------------------------
tcDefaultAssocDecl :: TyCon -- ^ Family TyCon
- -> LTyClDecl Name -- ^ RHS
+ -> LFamInstDecl Name -- ^ RHS
-> TcM ATDefault -- ^ Type checked RHS and free TyVars
tcDefaultAssocDecl fam_tc (L loc decl)
= setSrcSpan loc $
- tcAddDefaultAssocDeclCtxt (tcdName decl) $
+ tcAddFamInstCtxt decl $
do { traceTc "tcDefaultAssocDecl" (ppr decl)
; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl
; return (ATD at_tvs at_tys at_rhs loc) }
-- We check for well-formedness and validity later, in checkValidClass
-------------------------
-tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type)
+tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type)
-- Placed here because type family instances appear as
-- default decls in class declarations
-tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats
- , tcdSynRhs = hs_ty })
+tcSynFamInstDecl fam_tc (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym hs_ty) })
= do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
- ; tcFamTyPats fam_tc tvs pats
- (discardResult . tcCheckLHsType hs_ty)
- $ \tvs' pats' res_kind -> do
- { rhs_ty <- tcCheckLHsType hs_ty res_kind
+ ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind ->
+ do { rhs_ty <- tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; traceTc "tcSynFamInstDecl" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty))
; return (tvs', pats', rhs_ty) } }
@@ -720,7 +718,7 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
-----------------
tcFamTyPats :: TyCon
- -> [LHsTyVarBndr Name] -> [LHsType Name]
+ -> HsBndrSig [LHsType Name] -- Patterns
-> (TcKind -> TcM ()) -- Kind checker for RHS
-- result is ignored
-> ([TKVar] -> [TcType] -> Kind -> TcM a)
@@ -736,7 +734,7 @@ tcFamTyPats :: TyCon
-- In that case, the type variable 'a' will *already be in scope*
-- (and, if C is poly-kinded, so will its kind parameter).
-tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside
+tcFamTyPats fam_tc (HsBSig arg_pats tyvars) kind_checker thing_inside
= do { -- A family instance must have exactly the same number of type
-- parameters as the family declaration. You can't write
-- type family F a :: * -> *
@@ -755,7 +753,7 @@ tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside
-- Kind-check and quantify
-- See Note [Quantifying over family patterns]
- ; (tkvs, typats) <- tcHsTyVarBndrsGen tyvars $ do
+ ; (tkvs, typats) <- tcHsTyVarBndrsGen (map (noLoc . UserTyVar) tyvars) $ do
{ typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds
; kind_checker res_kind
; return (tyVarsOfTypes typats, typats) }
@@ -1636,6 +1634,14 @@ tcAddDefaultAssocDeclCtxt name thing_inside
ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"),
quotes (ppr name)]
+tcAddFamInstCtxt :: FamInstDecl Name -> TcM a -> TcM a
+tcAddFamInstCtxt (FamInstDecl { fid_tycon = tc, fid_defn = defn }) thing_inside
+ = addErrCtxt ctxt thing_inside
+ where
+ ctxt = hsep [ptext (sLit "In the") <+> pprTyDefnFlavour defn
+ <+> ptext (sLit "instance declaration for"),
+ quotes (ppr tc)]
+
resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
resultTypeMisMatch field_name con1 con2
= vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
View Lorry Controller Status