diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ae7a3cc2713a..a318b4946e52 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -265,17 +265,26 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour, +repFamilyDecl (L loc (FamilyDecl { fdInfo = info, fdLName = tc, fdTyVars = tvs, fdKindSig = opt_kind })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - do { flav <- repFamilyFlavour flavour - ; case opt_kind of - Nothing -> repFamilyNoKind flav tc1 bndrs - Just ki -> do { ki1 <- repLKind ki - ; repFamilyKind flav tc1 bndrs ki1 } + do { info' <- repFamilyInfo info + ; case (opt_kind, info) of + (Nothing, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; repClosedFamilyNoKind tc1 bndrs eqns2 } + (Just ki, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; ki1 <- repLKind ki + ; repClosedFamilyKind tc1 bndrs ki1 eqns2 } + (Nothing, _) -> repFamilyNoKind info' tc1 bndrs + (Just ki, _) -> do { ki1 <- repLKind ki + ; repFamilyKind info' tc1 bndrs ki1 } } ; return (loc, dec) } @@ -324,9 +333,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs -- represent family declaration flavours -- -repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) -repFamilyFlavour TypeFamily = rep2 typeFamName [] -repFamilyFlavour DataFamily = rep2 dataFamName [] +repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour) +repFamilyInfo OpenTypeFamily = rep2 typeFamName [] +repFamilyInfo DataFamily = rep2 dataFamName [] +repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo" -- Represent instance declarations -- @@ -369,12 +379,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) -repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns }) +repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; eqns1 <- mapM repTyFamEqn eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; repTySynInst tc eqns2 } + ; eqn1 <- repTyFamEqn eqn + ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys @@ -1695,9 +1704,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) = rep2 familyKindDName [flav, nm, tvs, ki] -repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) -repTySynInst (MkC nm) (MkC eqns) - = rep2 tySynInstDName [nm, eqns] +repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) +repTySynInst (MkC nm) (MkC eqn) + = rep2 tySynInstDName [nm, eqn] + +repClosedFamilyNoKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns) + = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns] + +repClosedFamilyKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns) + = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns] repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn (MkC lhs) (MkC rhs) @@ -2001,7 +2025,8 @@ templateHaskellNames = [ pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, infixLDName, infixRDName, infixNDName, + tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, -- Cxt cxtName, -- Pred @@ -2214,6 +2239,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, + closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey @@ -2234,6 +2260,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +closedTypeFamilyKindDName + = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey +closedTypeFamilyNoKindDName + = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey infixLDName = libFun (fsLit "infixLD") infixLDIdKey infixRDName = libFun (fsLit "infixRD") infixRDIdKey infixNDName = libFun (fsLit "infixND") infixNDIdKey @@ -2550,29 +2580,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, familyNoKindDIdKey, familyKindDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 330 -valDIdKey = mkPreludeMiscIdUnique 331 -dataDIdKey = mkPreludeMiscIdUnique 332 -newtypeDIdKey = mkPreludeMiscIdUnique 333 -tySynDIdKey = mkPreludeMiscIdUnique 334 -classDIdKey = mkPreludeMiscIdUnique 335 -instanceDIdKey = mkPreludeMiscIdUnique 336 -sigDIdKey = mkPreludeMiscIdUnique 337 -forImpDIdKey = mkPreludeMiscIdUnique 338 -pragInlDIdKey = mkPreludeMiscIdUnique 339 -pragSpecDIdKey = mkPreludeMiscIdUnique 340 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 412 -pragRuleDIdKey = mkPreludeMiscIdUnique 413 -familyNoKindDIdKey = mkPreludeMiscIdUnique 342 -familyKindDIdKey = mkPreludeMiscIdUnique 343 -dataInstDIdKey = mkPreludeMiscIdUnique 344 -newtypeInstDIdKey = mkPreludeMiscIdUnique 345 -tySynInstDIdKey = mkPreludeMiscIdUnique 346 -infixLDIdKey = mkPreludeMiscIdUnique 347 -infixRDIdKey = mkPreludeMiscIdUnique 348 -infixNDIdKey = mkPreludeMiscIdUnique 349 +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 412 +pragRuleDIdKey = mkPreludeMiscIdUnique 413 +familyNoKindDIdKey = mkPreludeMiscIdUnique 342 +familyKindDIdKey = mkPreludeMiscIdUnique 343 +dataInstDIdKey = mkPreludeMiscIdUnique 344 +newtypeInstDIdKey = mkPreludeMiscIdUnique 345 +tySynInstDIdKey = mkPreludeMiscIdUnique 346 +closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347 +closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348 +infixLDIdKey = mkPreludeMiscIdUnique 349 +infixRDIdKey = mkPreludeMiscIdUnique 350 +infixNDIdKey = mkPreludeMiscIdUnique 351 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 8caf9873367e..a07fafe00d4a 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind) ; kind' <- cvtMaybeKind kind ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) } where - cvtFamFlavour TypeFam = TypeFamily + cvtFamFlavour TypeFam = OpenTypeFamily cvtFamFlavour DataFam = DataFamily cvtDec (DataInstD ctxt tc tys constrs derivs) @@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' , dfid_defn = defn, dfid_fvs = placeHolderNames } }} -cvtDec (TySynInstD tc eqns) +cvtDec (TySynInstD tc eqn) = do { tc' <- tconNameL tc - ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; eqn' <- cvtTySynEqn tc' eqn ; returnL $ InstD $ TyFamInstD - { tfid_inst = TyFamInstDecl { tfid_eqns = eqns' - , tfid_group = (length eqns' /= 1) + { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames } } } + +cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars + ; mkind' <- cvtMaybeKind mkind + ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 2f1a7888e92c..e088af7c18f8 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -618,6 +618,9 @@ pprFlavour DataFamily = ptext (sLit "data family") pprFlavour OpenTypeFamily = ptext (sLit "type family") pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family") +instance Outputable (FamilyInfo name) where + ppr = pprFlavour + pp_vanilla_decl_head :: OutputableBndr name => Located name -> LHsTyVarBndrs name diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 8ef1ea8c4d77..f6ff9142c2fb 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -311,7 +311,6 @@ mkIface_ hsc_env maybe_old_fingerprint mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities } } - ; (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} addFingerprints hsc_env maybe_old_fingerprint diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 64a02097d8b0..163af051e8d3 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1280,10 +1280,12 @@ implicitTyConThings tc extras_plus :: TyThing -> [TyThing] extras_plus thing = thing : implicitTyThings thing --- For newtypes (only) add the implicit coercion tycon +-- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyCon_maybe tc + = [ACoAxiom co] | otherwise = [] -- | Returns @True@ if there should be no interface-file declaration diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 7ef2a854c075..4dd2961c8101 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -175,13 +175,13 @@ pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon = case syn_rhs of - IfaceOpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> + OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) - IfaceClosedSynFamilyTyCon ax -> + ClosedSynFamilyTyCon ax -> hang (pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> equals) 2 (ppr ax) - IfaceSynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) + SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! -- e.g. type T = forall a. a->a | Just cls <- GHC.tyConClass_maybe tyCon diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index f113d6bb8e79..c36a0fa29327 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -65,6 +65,7 @@ newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch , fi_tcs = roughMatchTcs lhs , fi_tvs = tvs' , fi_tys = substTys subst lhs + , fi_rhs = substTy subst rhs , fi_axiom = axiom }) } where fam_tc_name = tyConName fam_tc @@ -236,10 +237,8 @@ tcLookupDataFamInst tycon tys ; case maybeFamInst of Nothing -> famInstNotFound tycon tys Just (FamInstMatch { fim_instance = famInst - , fim_index = index , fim_tys = tys }) - -> ASSERT( index == 0 ) - let tycon' = dataFamInstRepTyCon famInst + -> let tycon' = dataFamInstRepTyCon famInst in return (tycon', tys) } famInstNotFound :: TyCon -> [Type] -> TcM a @@ -339,7 +338,7 @@ environments (one for the EPS and one for the HPT). checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - no_conflicts = all null conflicts + no_conflicts = null conflicts ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) ; unless no_conflicts $ conflictInstErr fam_inst conflicts ; return no_conflicts } @@ -362,7 +361,7 @@ addFamInstsErr herald insts where getSpan = getSrcLoc . famInstAxiom sorted = sortWith getSpan insts - (fi1,ix1) = head sorted + fi1 = head sorted srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1c9018512023..b6d0b7c4bcde 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -46,7 +46,6 @@ import RdrName import Name import NameSet import TyCon -import CoAxiom import TcType import Var import VarSet @@ -551,8 +550,9 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats , dfid_defn = HsDataDefn { dd_derivs = Just preds } }) = tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupTyCon tc_name - ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ -> - mapM (deriveTyData tvs' fam_tc pats') preds } + ; tcFamTyPats tc_name (tyConKind 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) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 49f12ee0685e..13761a5d183e 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1245,9 +1245,8 @@ tcTagToEnum loc fun_name arg res_ty ; case mb_fam of Nothing -> failWithTc (tagToEnumError ty doc3) Just (FamInstMatch { fim_instance = rep_fam - , fim_index = index , fim_tys = rep_args }) - -> return ( mkTcSymCo (mkTcAxInstCo co_tc index rep_args) + -> return ( mkTcSymCo (mkTcUnbranchedAxInstCo co_tc rep_args) , rep_tc, rep_args ) where co_tc = famInstAxiom rep_fam diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index d52bdcc4213d..b31d7418fa41 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -51,7 +51,6 @@ import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon -import CoAxiom import TcType import TysPrim import TysWiredIn diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 026a3ddd9b00..8ea0efb665f7 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -27,7 +27,6 @@ import TcType import TcGenDeriv import DataCon import TyCon -import CoAxiom import Coercion ( mkSingleCoAxiom ) import FamInstEnv ( FamInst, FamFlavor(..) ) import FamInst @@ -445,7 +444,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = (nameSrcSpan (tyConName tycon)) ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy - ; newFamInst OpenTypeFamily axiom } + ; newFamInst SynFamilyInst axiom } -------------------------------------------------------------------------------- -- Type representation diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 38718ea39d04..100d92cff5b4 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -18,7 +18,7 @@ module TcHsType ( UserTypeCtxt(..), -- Type checking type and class decls - kcTyClTyVars, tcTyClTyVars, + kcLookupKind, kcTyClTyVars, tcTyClTyVars, tcHsConArgType, tcDataKindSig, tcClassSigType, diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f246b257d9c6..67e35dae0c0f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -31,7 +31,7 @@ import TcRnMonad import TcValidity import TcMType import TcType -import Coercion( mkSingleCoAxiom, mkBranchedCoAxiom, pprCoAxBranch ) +import Coercion( mkSingleCoAxiom, mkUnbranchedCoAxiom ) import BuildTyCl import Inst import InstEnv @@ -466,7 +466,7 @@ addFamInsts fam_insts thing_inside ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } where - axioms = map famInstAxiom fam_insts + axioms = map (toBranchedAxiom . famInstAxiom) fam_insts tycons = famInstsRepTyCons fam_insts things = map ATyCon tycons ++ map ACoAxiom axioms \end{code} @@ -501,11 +501,11 @@ tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) = do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl) - ; return ([], [toBranchedFamInst fam_inst]) } + ; return ([], [fam_inst]) } tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = do { (insts, fam_insts) <- tcClsInstDecl (L loc decl) - ; return (insts, map toBranchedFamInst fam_insts) } + ; return (insts, fam_insts) } tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds @@ -559,7 +559,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst OpenTypeFamily axiom } + newFamInst SynFamilyInst axiom } ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) @@ -585,7 +585,7 @@ tcAssocTyDecl :: Class -- Class of associated type -> TcM (FamInst) tcAssocTyDecl clas mini_env ldecl = do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl - ; return $ toUnbranchedFamInst fam_inst } + ; return fam_inst } \end{code} %************************************************************************ @@ -623,7 +623,7 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable -> LTyFamInstDecl Name -> TcM FamInst -- "type instance" -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqns = eqns })) +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ do { let fam_lname = tfie_tycon (unLoc eqn) @@ -645,8 +645,8 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqns = eqns })) ; rep_tc_name <- newFamInstAxiomName loc (tyFamInstDeclName decl) [co_ax_branch] - ; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches - ; newFamInst OpenTypeFamily axiom } + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } tcDataFamInstDecl :: Maybe (Class, VarEnv Type) -> LDataFamInstDecl Name -> TcM FamInst @@ -666,7 +666,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc pats (kcDataDefn defn) $ + ; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats (kcDataDefn defn) $ \tvs' pats' res_kind -> do { -- Check that left-hand side contains no type family applications @@ -707,7 +707,7 @@ tcDataFamInstDecl mb_clsinfo -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. - ; fam_inst <- newFamInst (DataFamily rep_tc) axiom + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom ; return (rep_tc, fam_inst) } -- Remember to check validity; no recursion to worry about here @@ -1499,11 +1499,6 @@ badFamInstDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch tc fi - = ptext (sLit "Inaccessible family instance equation:") $$ - (pprCoAxBranch tc fi) - notOpenFamily :: TyCon -> SDoc notOpenFamily tc = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index ce03a9e68560..e9802751fdec 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -20,7 +20,7 @@ import VarSet import Type import Unify import FamInstEnv -import Coercion( mkAxInstRHS ) +import Coercion( mkUnbranchedAxInstRHS ) import Var import TcType @@ -1483,7 +1483,6 @@ doTopReactFunEq _ct fl fun_tc args xi loc ; case match_res of { Nothing -> return NoTopInt ; Just (FamInstMatch { fim_instance = famInst - , fim_index = index , fim_tys = rep_tys }) -> -- Found a top-level instance @@ -1491,8 +1490,8 @@ doTopReactFunEq _ct fl fun_tc args xi loc unless (isDerived fl) (addSolvedFunEq fam_ty fl xi) ; let coe_ax = famInstAxiom famInst - ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax index rep_tys) - (mkAxInstRHS coe_ax index rep_tys) } } } } } + ; succeed_with "Fun/Top" (mkTcUnbranchedAxInstCo coe_ax rep_tys) + (mkUnbranchedAxInstRHS coe_ax rep_tys) } } } } } where fam_ty = mkTyConApp fun_tc args @@ -1766,11 +1765,11 @@ matchClassInst _ clas [ k, ty ] _ { fim_instance = FamInst { fi_axiom = axDataFam , fi_flavor = DataFamilyInst tcon } - , fim_index = ix, fim_tys = tys + , fim_tys = tys } | Just (_,_,axSing) <- unwrapNewTyCon_maybe tcon -> do let co1 = mkTcSymCo $ mkTcUnbranchedAxInstCo axSing tys - co2 = mkTcSymCo $ mkTcAxInstCo axDataFam ix tys + co2 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDataFam tys co3 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDict [k,ty] return $ GenInst [] $ EvCast (EvLit evLit) $ mkTcTransCo co1 $ mkTcTransCo co2 co3 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8fa4cf46efe0..c9dca609b5a6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -460,6 +460,7 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env + } } tc_rn_src_decls :: ModDetails @@ -487,7 +488,7 @@ tc_rn_src_decls boot_details ds case group_tail of { Nothing -> do { tcg_env <- checkMain ; -- Check for `main' traceTc "returning from tc_rn_src_decls: " $ - ppr $ nameEnvElts $ tcg_type_env tcg_env ; -- RAE + ppr $ nameEnvElts $ tcg_type_env tcg_env ; return (tcg_env, tcl_env) } ; @@ -957,7 +958,6 @@ tcTopSrcDecls boot_details -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] addUsedRdrNames fo_rdr_names ; - traceTc "Tc8: type_env: " (ppr $ nameEnvElts $ tcg_type_env tcg_env') ; -- RAE return (tcg_env', tcl_env) }}}}}} where @@ -1655,13 +1655,8 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_vects = vects', tcg_fords = fords' } - tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env - - traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE - - return tcg_env'' - - + setGlobalTypeEnv tcg_env' final_type_env + #endif /* GHCi */ \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b2848e9ae215..b8437b8715d2 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1169,7 +1169,6 @@ reifyThing (AGlobal (AnId id)) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1192,12 +1191,7 @@ reifyThing (ATyVar tv tv1) reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) ------------------------------- -reifyAxiom :: CoAxiom br -> TcM TH.Info -reifyAxiom (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = do { eqns <- sequence $ brListMap reifyAxBranch branches - ; return (TH.TyConI (TH.TySynInstD (reifyName tc) eqns)) } - +------------------------------------------- reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs }) = do { args' <- mapM reifyType args @@ -1216,18 +1210,24 @@ reifyTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) | isFamilyTyCon tc - = do { let flavour = reifyFamFlavour tc - tvs = tyConTyVars tc + = do { let tvs = tyConTyVars tc kind = tyConKind tc ; kind' <- if isLiftedTypeKind kind then return Nothing else fmap Just (reifyKind kind) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc) ; tvs' <- reifyTyVars tvs - ; return (TH.FamilyI - (TH.FamilyD flavour (reifyName tc) tvs' kind') - instances) } + ; flav' <- reifyFamFlavour tc + ; case flav' of + { Left flav -> -- open type/data family + do { fam_envs <- tcGetFamInstEnvs + ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.FamilyD flav (reifyName tc) tvs' kind') + instances) } + ; Right eqns -> -- closed type family + return (TH.FamilyI + (TH.ClosedTypeFamilyD (reifyName tc) tvs' kind' eqns) + []) } } | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs @@ -1309,20 +1309,19 @@ reifyClassInstance i ------------------------------ reifyFamilyInstance :: FamInst -> TcM TH.Dec -reifyFamilyInstance fi@(FamInst { fi_flavor = flavor - , fi_fam = fam }) +reifyFamilyInstance (FamInst { fi_flavor = flavor + , fi_fam = fam + , fi_tys = lhs + , fi_rhs = rhs }) = case flavor of SynFamilyInst -> - do { let lhs = famInstLHS fi - rhs = famInstRHS fi - ; th_lhs <- reifyTypes lhs + do { th_lhs <- reifyTypes lhs ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (reifyName fam) th_lhs th_rhs) } + ; return (TH.TySynInstD (reifyName fam) (TH.TySynEqn th_lhs th_rhs)) } DataFamilyInst rep_tc -> do { let tvs = tyConTyVars rep_tc fam' = reifyName fam - lhs = famInstBranchLHS $ famInstSingleBranch (toUnbranchedFamInst fi) ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) ; th_tys <- reifyTypes lhs ; return (if isNewTyCon rep_tc @@ -1390,11 +1389,17 @@ reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyFamFlavour :: TyCon -> TH.FamFlavour -reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam - | isFamilyTyCon tc = TH.DataFam - | otherwise - = panic "TcSplice.reifyFamFlavour: not a type family" +reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn]) +reifyFamFlavour tc + | isOpenSynFamilyTyCon tc = return $ Left TH.TypeFam + | isDataFamilyTyCon tc = return $ Left TH.DataFam + + | Just ax <- isClosedSynFamilyTyCon_maybe tc + = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax + ; return $ Right eqns } + + | otherwise + = panic "TcSplice.reifyFamFlavour: not a type family" reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] reifyTyVars = mapM reifyTyVar . filter isTypeVar diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 621191aca19c..4d334efeb630 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -37,11 +37,12 @@ import TcMType import TcType import TysWiredIn( unitTy ) import FamInst -import Coercion( mkCoAxBranch ) +import FamInstEnv( isDominatedBy ) +import Coercion( mkCoAxBranch, mkBranchedCoAxiom, pprCoAxBranch ) import Type import Kind import Class -import CoAxiom( CoAxBranch(..) ) +import CoAxiom import TyCon import DataCon import Id @@ -672,13 +673,14 @@ tcFamDecl1 parent ; let names = map (tfie_tycon . unLoc) eqns ; tcSynFamInstNames lname names + -- process the equations, creating CoAxBranches + ; tycon_kind <- kcLookupKind tc_name + ; branches <- mapM (tcTyFamInstEqn tc_name tycon_kind) eqns + -- we need the tycon that we will be creating, but it's in scope. -- just look it up. ; fam_tc <- tcLookupLocatedTyCon lname - -- process the equations, creating CoAxBranches - ; branches <- mapM (tcTyFamInstEqn fam_tc) eqns - -- create a CoAxiom, with the correct src location ; loc <- getSrcSpanM ; co_ax_name <- newFamInstAxiomName loc tc_name branches @@ -688,12 +690,12 @@ tcFamDecl1 parent ; let syn_rhs = ClosedSynFamilyTyCon co_ax ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent - ; return [ATyCon tycon, ACoAxiom axiom] } + ; return [ATyCon tycon, ACoAxiom co_ax] } -- We check for instance validity later, when doing validity checking for -- the tycon tcFamDecl1 parent - (FamilyDecl {fdFlavour = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + (FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name @@ -806,13 +808,13 @@ tcClassATs class_name parent ats at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at ; let at_defs = lookupNameEnv at_defs_map (unLoc $ fdLName $ unLoc at) `orElse` [] - ; atd <- concatMapM (tcDefaultAssocDecl fam_tc) at_defs + ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs ; return (fam_tc, atd) } ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon -> LTyFamInstDecl Name -- ^ RHS - -> TcM [CoAxBranch] -- ^ Type checked RHS and free TyVars + -> TcM CoAxBranch -- ^ Type checked RHS and free TyVars tcDefaultAssocDecl fam_tc (L loc decl) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ @@ -826,7 +828,7 @@ tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch -- default decls in class declarations tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn }) = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; tcTyFamInstEqn fam_tc eqn } + ; tcTyFamInstEqn (tyConName fam_tc) (tyConKind fam_tc) eqn } -- Checks to make sure that all the names in an instance group are the same tcSynFamInstNames :: Located Name -> [Located Name] -> TcM () @@ -839,15 +841,15 @@ tcSynFamInstNames (L _ first) names = setSrcSpan loc $ failWithTc (msg_fun name) -tcTyFamInstEqn :: TyCon -> LTyFamInstEqn Name -> TcM CoAxBranch -tcTyFamInstEqn fam_tc +tcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM CoAxBranch +tcTyFamInstEqn fam_tc_name kind (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) = setSrcSpan loc $ - tcFamTyPats fam_tc pats (discardResult . (tcCheckLHsType hs_ty)) $ + tcFamTyPats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) $ \tvs' pats' res_kind -> do { rhs_ty <- tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; traceTc "tcSynFamInstEqn" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) + ; traceTc "tcSynFamInstEqn" (ppr fam_tc_name <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) ; return (mkCoAxBranch tvs' pats' rhs_ty loc) } kcDataDefn :: HsDataDefn Name -> TcKind -> TcM () @@ -877,7 +879,11 @@ kcResultKind (Just k) res_k -- check is only required for type synonym instances. ----------------- -tcFamTyPats :: TyCon +-- Note that we can't use the family TyCon, because this is sometimes called +-- from within a type-checking knot. So, we ask our callers to do a little more +-- work. +tcFamTyPats :: Name -- of the family TyCon + -> Kind -- of the family TyCon -> HsWithBndrs [LHsType Name] -- Patterns -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored @@ -894,23 +900,21 @@ 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 (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) +tcFamTyPats fam_tc_name kind + (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) 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 :: * -> * -- type instance F Int y = y -- because then the type (F Int) would be like (\y.y) - ; let (fam_kvs, fam_body) = splitForAllTys (tyConKind fam_tc) - fam_arity = tyConArity fam_tc - length fam_kvs - ; checkTc (length arg_pats == fam_arity) $ - wrongNumberOfParmsErr fam_arity + ; let (fam_kvs, fam_body) = splitForAllTys kind -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs ; loc <- getSrcSpanM ; let (arg_kinds, res_kind) - = splitKindFunTysN fam_arity $ + = splitKindFunTysN (length arg_pats) $ substKiWith fam_kvs fam_arg_kinds fam_body hs_tvs = HsQTvs { hsq_kvs = kvars , hsq_tvs = userHsTyVarBndrs loc tvars } @@ -919,7 +923,7 @@ tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tva -- See Note [Quantifying over family patterns] ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds } + ; tcHsArgTys (quotes (ppr fam_tc_name)) arg_pats arg_kinds } ; let all_args = fam_arg_kinds ++ typats -- Find free variables (after zonking) and turn @@ -1248,7 +1252,7 @@ checkValidTyCl decl _ -> return () } checkValidFamDecl :: FamilyDecl Name -> TcM () -checkValidFamDecl (FamilyDecl { fdLName = lname, fdFlavour = flav }) +checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav }) = checkValidDecl (hsep [ptext (sLit "In the"), ppr flav, ptext (sLit "declaration for"), quotes (ppr lname)]) lname @@ -1344,7 +1348,7 @@ checkValidTyCon tc checkValidClosedCoAxiom :: CoAxiom Branched -> TcM () checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) = tcAddClosedTypeFamilyDeclCtxt tc $ - do { foldlM_ check_accessibility [] branches + do { brListFoldlM_ check_accessibility [] branches ; void $ brListMapM (checkValidTyFamInst Nothing tc) branches } where check_accessibility :: [CoAxBranch] -- prev branches (in reverse order) @@ -1355,7 +1359,7 @@ checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) check_accessibility prev_branches cur_branch = do { when (cur_branch `isDominatedBy` prev_branches) $ setSrcSpan (coAxBranchSpan cur_branch) $ - addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch + addErrTc $ inaccessibleCoAxBranch tc cur_branch ; return (cur_branch : prev_branches) } checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet @@ -1757,10 +1761,7 @@ tcAddDefaultAssocDeclCtxt name thing_inside tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl - | [_] <- tfid_eqns decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) - | otherwise - = tcAddFamInstCtxt (ptext (sLit "type instance group")) (tyFamInstDeclName decl) tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a tcAddDataFamInstCtxt decl @@ -1775,6 +1776,13 @@ tcAddFamInstCtxt flavour tycon thing_inside <+> ptext (sLit "declaration for"), quotes (ppr tycon)] +tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a +tcAddClosedTypeFamilyDeclCtxt tc + = addErrCtxt ctxt + where + ctxt = ptext (sLit "In the declaration for closed type family") <+> + 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, @@ -1882,11 +1890,6 @@ emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")] -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity - wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family = ptext (sLit "Wrong category of family instance; declaration was for a") @@ -1898,8 +1901,13 @@ wrongKindOfFamily family wrongNamesInInstGroup :: Name -> Name -> SDoc wrongNamesInInstGroup first cur - = ptext (sLit "Mismatched family names in instance group.") $$ + = ptext (sLit "Mismatched type names in closed type family declaration.") $$ ptext (sLit "First name was") <+> (ppr first) <> (ptext (sLit "; this one is")) <+> (ppr cur) +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch tc fi + = ptext (sLit "Inaccessible family instance equation:") $$ + (pprCoAxBranch tc fi) + \end{code} diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index e232598ea2ac..18238028cde9 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -45,6 +45,7 @@ import ListSetOps import SrcLoc import Outputable import FastString +import BasicTypes ( Arity ) import Control.Monad import Data.List ( (\\) ) @@ -1133,10 +1134,20 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () -- e.g. we disallow (Trac #7536) -- type T a = Int -- type instance F (T a) = a +-- c) Have the right number of patterns checkValidFamPats fam_tc tvs ty_pats - = do { mapM_ checkTyFamFreeness ty_pats + = do { checkTc (length ty_pats == fam_arity) $ + wrongNumberOfParmsErr fam_arity + ; mapM_ checkTyFamFreeness ty_pats ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) } + where fam_arity = tyConArity fam_tc - length fam_kvs + (fam_kvs, _) = splitForAllTys (tyConKind fam_tc) + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity -- Ensure that no type family instances occur in a type. -- diff --git a/compiler/types/CoAxiom.lhs b/compiler/types/CoAxiom.lhs index 273c36e86324..c29115ca68e5 100644 --- a/compiler/types/CoAxiom.lhs +++ b/compiler/types/CoAxiom.lhs @@ -4,7 +4,7 @@ \begin{code} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, ScopedTypeVariables #-} -- | Module for coercion axioms, used to represent type family instances -- and newtypes @@ -14,7 +14,7 @@ module CoAxiom ( toBranchList, fromBranchList, toBranchedList, toUnbranchedList, brListLength, brListNth, brListMap, brListFoldr, brListMapM, - brListZipWith, brListIndices, + brListFoldlM_, brListZipWith, CoAxiom(..), CoAxBranch(..), @@ -154,14 +154,6 @@ brListLength :: BranchList a br -> Int brListLength (FirstBranch _) = 1 brListLength (NextBranch _ t) = 1 + brListLength t --- Indices -brListIndices :: BranchList a br -> [BranchIndex] -brListIndices bs = go 0 bs - where - go :: BranchIndex -> BranchList a br -> [BranchIndex] - go n (NextBranch _ t) = n : go (n+1) t - go n (FirstBranch {}) = [n] - -- lookup brListNth :: BranchList a br -> BranchIndex -> a brListNth (FirstBranch b) 0 = b @@ -184,6 +176,15 @@ brListMapM f (NextBranch h t) = do { fh <- f h ; ft <- brListMapM f t ; return (fh : ft) } +brListFoldlM_ :: forall a b m br. Monad m + => (a -> b -> m a) -> a -> BranchList b br -> m () +brListFoldlM_ f z brs = do { _ <- go brs + ; return () } + where go :: forall br'. Monad m => BranchList b br' -> m a + go (FirstBranch b) = f z b + go (NextBranch h t) = do { t' <- go t + ; f t' h } + -- zipWith brListZipWith :: (a -> b -> c) -> BranchList a br1 -> BranchList b br2 -> [c] brListZipWith f (FirstBranch a) (FirstBranch b) = [f a b] diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 4ade32b0e9c5..c0a0a40c1c42 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -16,7 +16,7 @@ -- module Coercion ( -- * CoAxioms - mkCoAxBranch, mkBranchedCoAxiom, mkSingleCoAxiom, + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, -- * Main data type Coercion(..), Var, CoVar, @@ -153,6 +153,14 @@ mkBranchedCoAxiom ax_name fam_tc branches , co_ax_implicit = False , co_ax_branches = toBranchList branches } +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_implicit = False + , co_ax_branches = FirstBranch branch } + mkSingleCoAxiom :: Name -> [TyVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty = CoAxiom { co_ax_unique = nameUnique ax_name diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index d7b2ef9c3f18..cb2352561a3d 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -7,15 +7,16 @@ FamInstEnv: Type checked family instance declarations \begin{code} module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, pprFamInst, pprFamInstHdr, pprFamInsts, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, - identicalFamInst, famInstEnvElts, familyInstances, + identicalFamInst, famInstEnvElts, familyInstances, orphNamesOfFamInst, + FamInstMatch(..), lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', isDominatedBy, @@ -29,6 +30,7 @@ module FamInstEnv ( import InstEnv import Unify import Type +import TcType ( orphNamesOfTypes ) import TypeRep import TyCon import Coercion @@ -40,6 +42,7 @@ import UniqFM import Outputable import Maybes import Util +import NameSet import FastString \end{code} @@ -112,6 +115,10 @@ famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) famInstRHS :: FamInst -> Type famInstRHS = fi_rhs +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + -- Return the representation TyCons introduced by data family instances, if any famInstsRepTyCons :: [FamInst] -> [TyCon] famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] @@ -290,6 +297,17 @@ familyInstances (pkg_fie, home_fie) fam Just (FamIE insts _) -> insts Nothing -> [] +-- | Collects the names of the concrete types and type constructors that +-- make up the LHS of a type family instance. For instance, +-- given `type family Foo a b`: +-- +-- `type instance Foo (F (G (H a))) b = ...` would yield [F,G,H] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst + = orphNamesOfTypes . concat . brListMap cab_lhs . coAxiomBranches . fi_axiom + extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index ccaad4f55954..ee5469c637fa 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -34,7 +34,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isOpenSynFamilyTyCon, + isSynTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, @@ -46,6 +46,7 @@ module TyCon( isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, + isOpenSynFamilyTyCon, isClosedSynFamilyTyCon_maybe, isUnLiftedTyCon, isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, isTyConAssoc, tyConAssoc_maybe, @@ -1170,6 +1171,11 @@ isOpenSynFamilyTyCon :: TyCon -> Bool isOpenSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True isOpenSynFamilyTyCon _ = False +isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyCon_maybe + (SynTyCon {synTcRhs = ClosedSynFamilyTyCon ax}) = Just ax +isClosedSynFamilyTyCon_maybe _ = Nothing + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index b939f4beb63a..012ae37039cf 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -27,7 +27,6 @@ import DynFlags import Outputable import Util ( zipLazy ) import MonadUtils -import FamInstEnv ( toBranchedFamInst ) import Control.Monad @@ -93,7 +92,7 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- and dfuns , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = fam_insts ++ (map toBranchedFamInst new_fam_insts) + , mg_fam_insts = fam_insts ++ new_fam_insts } } diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index d088f453553e..0bd54f4408d3 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -39,8 +39,6 @@ import DataCon import MkId import DynFlags import FastString -import Util -import Panic #include "HsVersions.h" @@ -211,10 +209,8 @@ pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = do { FamInstMatch { fim_instance = famInst - , fim_index = index , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) - ; ASSERT( index == 0 ) - return (dataFamInstRepTyCon famInst, tys) + ; return (dataFamInstRepTyCon famInst, tys) } -- |Get the representation tycon of the 'PData' data family for a given type constructor. diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 8029dfb4662a..84a6ff37d912 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -119,7 +119,7 @@ prDictOfPReprInst :: Type -> VM CoreExpr prDictOfPReprInst ty = do { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty - ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args + ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args } -- |Given a type @ty@, its PRepr synonym tycon and its type arguments, diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 9c7104fb43c8..8fdf92142518 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1038,7 +1038,7 @@ filterOutChildren get_thing xs Nothing -> False pprInfo :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprInfo pefas (thing, fixity, cls_insts, fam_insts) = pprTyThingInContextLoc pefas thing $$ show_fixity @@ -2195,7 +2195,7 @@ showBindings = do return $ maybe (text "") (pprTT pefas) mb_stuff pprTT :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprTT pefas (thing, fixity, _cls_insts, _fam_insts) = pprTyThing pefas thing $$ show_fixity