diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 516e25a2b09fb365ea9e7bff6680da8af4993c65..6811b11e6f6c77fa39044bcad8790ffc8519cef3 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -26,7 +26,8 @@ module MkId (
wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut,
- wrapTypeFamInstBody, unwrapTypeFamInstScrut,
+ wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut,
+ unwrapTypeUnbranchedFamInstScrut,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
@@ -47,13 +48,15 @@ import TysPrim
import TysWiredIn
import PrelRules
import Type
-import Coercion ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo )
+import Coercion ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo,
+ mkUnbranchedAxInstCo )
import TcType
import MkCore
import CoreUtils ( exprType, mkCast )
import CoreUnfold
import Literal
import TyCon
+import CoAxiom
import Class
import VarSet
import Name
@@ -647,7 +650,7 @@ dataConArgUnpack arg_ty
unbox_tc_app tc tc_args con
| isNewTyCon tc
, let rep_ty = newTyConInstRhs tc tc_args
- co = mkAxInstCo (newTyConCo tc) tc_args -- arg_ty ~ rep_ty
+ co = mkUnbranchedAxInstCo (newTyConCo tc) tc_args -- arg_ty ~ rep_ty
, (yes, rep_tys, unbox_rep, box_rep) <- dataConArgUnpack rep_ty
= ( yes, rep_tys
, \ arg_id ->
@@ -661,7 +664,7 @@ dataConArgUnpack arg_ty
UnitBox -> do { rep_id <- newLocal (substTy subst rep_ty)
; return ([rep_id], Var rep_id) }
Boxer boxer -> boxer subst
- ; let sco = mkAxInstCo (newTyConCo tc) (substTys subst tc_args)
+ ; let sco = mkUnbranchedAxInstCo (newTyConCo tc) (substTys subst tc_args)
; return (rep_ids, rep_expr `Cast` mkSymCo sco) } )
| otherwise
@@ -769,7 +772,7 @@ wrapNewTypeBody tycon args result_expr
wrapFamInstBody tycon args $
mkCast result_expr (mkSymCo co)
where
- co = mkAxInstCo (newTyConCo tycon) args
+ co = mkUnbranchedAxInstCo (newTyConCo tycon) args
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker. We have to do it this way as
@@ -779,7 +782,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon )
- mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
+ mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args)
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
@@ -789,26 +792,34 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCast body (mkSymCo (mkAxInstCo co_con args))
+ = mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args))
| otherwise
= body
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
-wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
-wrapTypeFamInstBody axiom args body
- = mkCast body (mkSymCo (mkAxInstCo axiom args))
+wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
+wrapTypeFamInstBody axiom ind args body
+ = mkCast body (mkSymCo (mkAxInstCo axiom ind args))
+
+wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
+wrapTypeUnbranchedFamInstBody axiom
+ = wrapTypeFamInstBody axiom 0
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCast scrut (mkAxInstCo co_con args)
+ = mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only
| otherwise
= scrut
-unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
-unwrapTypeFamInstScrut axiom args scrut
- = mkCast scrut (mkAxInstCo axiom args)
+unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
+unwrapTypeFamInstScrut axiom ind args scrut
+ = mkCast scrut (mkAxInstCo axiom ind args)
+
+unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
+unwrapTypeUnbranchedFamInstScrut axiom
+ = unwrapTypeFamInstScrut axiom 0
\end{code}
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index c3f456bcb6492560b7a2d30bb91debc6d0f8bed4..a4a195846d6a987e2ab52396bf09a78da0d9552e 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -43,6 +43,7 @@ import Kind
import Type
import TypeRep
import TyCon
+import CoAxiom
import BasicTypes
import StaticFlags
import ListSetOps
@@ -50,6 +51,8 @@ import PrelNames
import Outputable
import FastString
import Util
+import Unify
+import InstEnv ( instanceBindFun )
import Control.Monad
import MonadUtils
import Data.Maybe
@@ -410,6 +413,30 @@ kind coercions and produce the following substitution which is to be
applied in the type variables:
k_ag ~~> * -> *
+Note [Conflict checking with AxiomInstCo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following type family and axiom:
+
+type family Equal (a :: k) (b :: k) :: Bool
+type instance where
+ Equal a a = True
+ Equal a b = False
+--
+Equal :: forall k::BOX. k -> k -> Bool
+axEqual :: { forall k::BOX. forall a::k. Equal k a a ~ True
+ ; forall k::BOX. forall a::k. forall b::k. Equal k a b ~ False }
+
+We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is 0-based,
+so this is the second branch of the axiom.) The problem is that, on the surface, it
+seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False) and that all is
+OK. But, all is not OK: we want to use the first branch of the axiom in this case,
+not the second. The problem is that the parameters of the first branch can unify with
+the supplied coercions, thus meaning that the first branch should be taken. See also
+Note [Instance checking within groups] in types/FamInstEnv.lhs.
+
+However, if the right-hand side of the previous branch coincides with the right-hand
+side of the selected branch, we wish to accept the AxiomInstCo. See also Note
+[Confluence checking within groups], also in types/FamInstEnv.lhs.
%************************************************************************
%* *
@@ -909,24 +936,40 @@ lintCoercion (InstCo co arg_ty)
-> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
_ -> failWithL (ptext (sLit "Bad argument of inst")) }
-lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
- , co_ax_lhs = lhs
- , co_ax_rhs = rhs })
- cos)
- = do { -- See Note [Kind instantiation in coercions]
- unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
+lintCoercion co@(AxiomInstCo con ind cos)
+ = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
+ (bad_ax (ptext (sLit "index out of range")))
+ -- See Note [Kind instantiation in coercions]
+ ; let CoAxBranch { cab_tvs = ktvs
+ , cab_lhs = lhs
+ , cab_rhs = rhs } = coAxiomNthBranch con ind
+ ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
; in_scope <- getInScope
; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
; (subst_l, subst_r) <- foldlM check_ki
(empty_subst, empty_subst)
(ktvs `zip` cos)
- ; let lhs' = Type.substTy subst_l lhs
+ ; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs
- ; return (typeKind lhs', lhs', rhs') }
+ ; case check_no_conflict lhs' (ind - 1) of
+ Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index)
+ Nothing -> return ()
+ ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
where
bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
2 (ppr co))
+ -- See Note [Conflict checking with AxiomInstCo]
+ check_no_conflict :: [Type] -> Int -> Maybe Int
+ check_no_conflict _ (-1) = Nothing
+ check_no_conflict lhs' j
+ | SurelyApart <- tcApartTys instanceBindFun lhs' lhsj
+ = check_no_conflict lhs' (j-1)
+ | otherwise
+ = Just j
+ where
+ (CoAxBranch { cab_lhs = lhsj }) = coAxiomNthBranch con j
+
check_ki (subst_l, subst_r) (ktv, co)
= do { (k, t1, t2) <- lintCoercion co
; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index 287f08049e36f05eb3276289670e3329a0fd5c10..15de06c6ce1aa027855218f31cff009203d08e50 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -74,6 +74,7 @@ data Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
| NthCoercion Int Ty
+ | AxiomCoercion (Qual Tcon) Int [Ty]
| LRCoercion LeftOrRight Ty
data LeftOrRight = CLeft | CRight
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 164146ad43238a5061a889cf1d80823f2dc155e2..aa5e365be9da30e2b189574423b9d11630e63df4 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -20,6 +20,7 @@ import Module
import CoreSyn
import HscTypes
import TyCon
+import CoAxiom
-- import Class
import TypeRep
import Type
@@ -112,7 +113,7 @@ collect_tdefs _ _ tdefs = tdefs
qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
qtc dflags = make_con_qid dflags . tyConName
-qcc :: DynFlags -> CoAxiom -> C.Qual C.Tcon
+qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon
qcc dflags = make_con_qid dflags . co_ax_name
make_cdef :: DynFlags -> DataCon -> C.Cdef
@@ -322,7 +323,7 @@ make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos
make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2)
make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co)
make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
-make_co dflags (AxiomInstCo cc cos) = make_conAppCo dflags (qcc dflags cc) cos
+make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index 6bc78a82728a2d8c9a59650052177b99c838a83d..148464b85235b19fab9b6ca43bf8bc387b001d37 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -465,7 +465,7 @@ data CoercionMap a
, km_app :: CoercionMap (CoercionMap a)
, km_forall :: CoercionMap (TypeMap a)
, km_var :: VarMap a
- , km_axiom :: NameEnv (ListMap CoercionMap a)
+ , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a))
, km_unsafe :: TypeMap (TypeMap a)
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
@@ -503,7 +503,7 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = mapTM (mapTM f) kapp
, km_forall = mapTM (mapTM f) kforall
, km_var = mapTM f kvar
- , km_axiom = mapNameEnv (mapTM f) kax
+ , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax
, km_unsafe = mapTM (mapTM f) kunsafe
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
@@ -517,36 +517,36 @@ lkC env co m
| EmptyKM <- m = Nothing
| otherwise = go co m
where
- go (Refl ty) = km_refl >.> lkT env ty
- go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
- go (AxiomInstCo ax cs) = km_axiom >.> lkNamed ax >=> lkList (lkC env) cs
- go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2
- go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2
- go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2
- go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t
- go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
- go (CoVarCo v) = km_var >.> lkVar env v
- go (SymCo c) = km_sym >.> lkC env c
- go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
- go (LRCo CLeft c) = km_left >.> lkC env c
- go (LRCo CRight c) = km_right >.> lkC env c
+ go (Refl ty) = km_refl >.> lkT env ty
+ go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
+ go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs
+ go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2
+ go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2
+ go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2
+ go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t
+ go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
+ go (CoVarCo v) = km_var >.> lkVar env v
+ go (SymCo c) = km_sym >.> lkC env c
+ go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
+ go (LRCo CLeft c) = km_left >.> lkC env c
+ go (LRCo CRight c) = km_right >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
-xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f }
-xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
-xtC env (AxiomInstCo ax cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtList (xtC env) cs f }
-xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f }
-xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f }
-xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
-xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
-xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
- |>> xtBndr env v f }
-xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
-xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
-xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
-xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
-xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
+xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f }
+xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
+xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f }
+xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f }
+xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f }
+xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
+xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
+xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
+ |>> xtBndr env v f }
+xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
+xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
+xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
+xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
+xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
@@ -555,7 +555,7 @@ fdC k m = foldTM k (km_refl m)
. foldTM (foldTM k) (km_app m)
. foldTM (foldTM k) (km_forall m)
. foldTM k (km_var m)
- . foldTM (foldTM k) (km_axiom m)
+ . foldTM (foldTM (foldTM k)) (km_axiom m)
. foldTM (foldTM k) (km_unsafe m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 4b7f8c0dd4e3df6fd64c8401961840ba95f50cb2..78d85690910e6a48dad313000908e0ef40963f52 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -830,7 +830,8 @@ ds_tc_coercion subst tc_co
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
- go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
+ go (TcAxiomInstCo ax ind tys)
+ = mkAxInstCo ax ind (map (Coercion.substTy subst) tys)
go (TcSymCo co) = mkSymCo (go co)
go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
go (TcNthCo n co) = mkNthCo n (go co)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f25039c8a95ff835cd6d49d7174329bc78425bb1..fcaff4bd9a7ed4a812c5dbe0e565cf1d41962723 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -65,7 +65,6 @@ import Bag
import DynFlags
import FastString
import ForeignCall
-import MonadUtils
import Util
import Data.Maybe
@@ -203,31 +202,21 @@ in repTyClD and repC.
-- represent associated family instances
--
-repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
-repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds)
-
-
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
-repTyClD (L loc (TyFamily { tcdFlavour = flavour,
- tcdLName = tc, tcdTyVars = tvs,
- tcdKindSig = 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 }
- }
- ; return $ Just (loc, dec)
- }
+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
+
+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
+ ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+ repSynDecl tc1 bndrs rhs
+ ; return (Just (loc, dec)) }
-repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn }))
+repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; tc_tvs <- mk_extra_tvs tc tvs defn
; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
- repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
+ repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
@@ -240,7 +229,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; sigs1 <- rep_sigs sigs
; binds1 <- rep_binds meth_binds
; fds1 <- repLFunDeps fds
- ; ats1 <- repTyClDs ats
+ ; ats1 <- repFamilyDecls ats
; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
; repClass cxt1 cls1 bndrs fds1 decls1
}
@@ -253,13 +242,13 @@ repTyClD (L loc d) = putSrcSpanDs loc $
; return Nothing }
-------------------------
-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 })
+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
+ -> Maybe (Core [TH.TypeQ])
+ -> [Name] -> HsDataDefn Name
+ -> DsM (Core TH.DecQ)
+repDataDefn tc bndrs opt_tys tv_names
+ (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
+ , dd_cons = cons, dd_derivs = mb_derivs })
= do { cxt1 <- repLContext cxt
; derivs1 <- repDerivs mb_derivs
; case new_or_data of
@@ -268,18 +257,40 @@ repTyDefn tc bndrs opt_tys tv_names
DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
-repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
+ -> LHsType Name
+ -> DsM (Core TH.DecQ)
+repSynDecl tc bndrs ty
= do { ty1 <- repLTy ty
- ; repTySyn tc bndrs opt_tys ty1 }
+ ; repTySyn tc bndrs ty1 }
+
+repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
+ 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 }
+ }
+ ; return (loc, dec)
+ }
+
+repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
-------------------------
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
- -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
+ -> HsDataDefn Name -> DsM (LHsTyVarBndrs 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 tc tvs defn
- | TyData { td_kindSig = Just hs_kind } <- defn
+ | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
= do { extra_tvs <- go hs_kind
; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
| otherwise
@@ -320,13 +331,21 @@ repFamilyFlavour DataFamily = rep2 dataFamName []
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repInstD (L loc (FamInstD { lid_inst = fi_decl }))
- = do { dec <- repFamInstD fi_decl
+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
+ = do { dec <- repTyFamInstD fi_decl
+ ; return (loc, dec) }
+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
+ = do { dec <- repDataFamInstD fi_decl
+ ; return (loc, dec) }
+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
+ = do { dec <- repClsInstD cls_decl
; return (loc, dec) }
-repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
- , cid_sigs = prags, cid_fam_insts = ats }))
- = do { dec <- addTyVarBinds tvs $ \_ ->
+repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
+ , cid_sigs = prags, cid_tyfam_insts = ats
+ , cid_datafam_insts = adts })
+ = addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure
@@ -342,25 +361,44 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags
- ; ats1 <- mapM (repFamInstD . unLoc) ats
- ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
+ ; ats1 <- mapM (repTyFamInstD . unLoc) ats
+ ; adts1 <- mapM (repDataFamInstD . unLoc) adts
+ ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls }
- ; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
-repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
-repFamInstD (FamInstDecl { fid_tycon = tc_name
- , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
- , fid_defn = defn })
- = WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind
- -- polymorphism in Template Haskell (sigh)
- do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
+repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
+repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
+ = 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 }
+
+repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
+ , hswb_kvs = kv_names
+ , hswb_tvs = tv_names }
+ , tfie_rhs = rhs }))
+ = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
+ , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
+ ; addTyClTyVarBinds hs_tvs $ \ _ ->
+ do { tys1 <- repLTys tys
+ ; tys2 <- coreList typeQTyConName tys1
+ ; rhs1 <- repLTy rhs
+ ; repTySynEqn tys2 rhs1 } }
+
+repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
+repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
+ , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
+ , dfid_defn = defn })
+ = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name
hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repList typeQTyConName repLTy tys
- ; repTyDefn tc bndrs (Just tys1) tv_names defn } }
+ ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
@@ -1607,12 +1645,9 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
= rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
- -> Maybe (Core [TH.TypeQ])
-> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
-repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
- = rep2 tySynInstDName [nm, tys, rhs]
repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
@@ -1657,6 +1692,14 @@ 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]
+
+repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC lhs) (MkC rhs)
+ = rep2 tySynEqnName [lhs, rhs]
+
repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
@@ -1997,6 +2040,8 @@ templateHaskellNames = [
funDepName,
-- FamFlavour
typeFamName, dataFamName,
+ -- TySynEqn
+ tySynEqnName,
-- And the tycons
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
@@ -2005,7 +2050,7 @@ templateHaskellNames = [
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
- predQTyConName, decsQTyConName, ruleBndrQTyConName,
+ predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -2304,11 +2349,15 @@ typeFamName, dataFamName :: Name
typeFamName = libFun (fsLit "typeFam") typeFamIdKey
dataFamName = libFun (fsLit "dataFam") dataFamIdKey
+-- data TySynEqn = ...
+tySynEqnName :: Name
+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
+
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
- ruleBndrQTyConName :: Name
+ ruleBndrQTyConName, tySynEqnQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
@@ -2324,6 +2373,7 @@ patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
predQTyConName = libTc (fsLit "PredQ") predQTyConKey
ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
+tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -2341,7 +2391,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
- predQTyConKey, decsQTyConKey, ruleBndrQTyConKey :: Unique
+ predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -2370,6 +2420,7 @@ predQTyConKey = mkPreludeTyConUnique 224
tyVarBndrTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrQTyConKey = mkPreludeTyConUnique 227
+tySynEqnQTyConKey = mkPreludeTyConUnique 228
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in PrelNames
@@ -2629,6 +2680,10 @@ typeFamIdKey, dataFamIdKey :: Unique
typeFamIdKey = mkPreludeMiscIdUnique 415
dataFamIdKey = mkPreludeMiscIdUnique 416
+-- data TySynEqn = ...
+tySynEqnIdKey :: Unique
+tySynEqnIdKey = mkPreludeMiscIdUnique 417
+
-- quasiquoting
quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
quoteExpKey = mkPreludeMiscIdUnique 418
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 3e7cd42c79275f0d09650bb4a0942d7cf79df71f..44d0952b33b567026efacc0b1e4104c5a053127c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -384,6 +384,7 @@ Library
FunDeps
InstEnv
TyCon
+ CoAxiom
Kind
Type
TypeRep
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index d7ad1132ec2754a909fdb88dbb6de800fa2fd54f..c5a92f8b280fa5e745c4dd255709f05acfeabed0 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -156,36 +156,39 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
- ; returnL $ TyClD (TyDecl { tcdLName = tc'
+ ; returnL $ TyClD (SynDecl { tcdLName = tc'
, tcdTyVars = tvs', tcdFVs = placeHolderNames
- , tcdTyDefn = TySynonym rhs' }) }
+ , tcdRhs = rhs' }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs 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 }) }
+ ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+ , dd_ctxt = ctxt'
+ , dd_kindSig = Nothing
+ , dd_cons = cons', dd_derivs = derivs' }
+ ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+ , tcdDataDefn = 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
- ; let defn = TyData { td_ND = NewType, 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 }) }
+ ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+ , dd_ctxt = ctxt'
+ , dd_kindSig = Nothing
+ , dd_cons = [con'], dd_derivs = derivs' }
+ ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+ , tcdDataDefn = 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', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+ ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+ ; unless (null adts')
+ (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
+ $$ (Outputable.ppr adts'))
; returnL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
@@ -196,12 +199,12 @@ cvtDec (ClassD ctxt cl tvs fds decs)
cvtDec (InstanceD ctxt ty decs)
= do { let doc = ptext (sLit "an instance declaration")
- ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs
+ ; (binds', sigs', fams', ats', adts') <- 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 (ClsInstD inst_ty' binds' sigs' ats') }
+ ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
@@ -210,7 +213,7 @@ cvtDec (ForeignD ford)
cvtDec (FamilyD flav tc tvs kind)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; kind' <- cvtMaybeKind kind
- ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
+ ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
where
cvtFamFlavour TypeFam = TypeFamily
cvtFamFlavour DataFam = DataFamily
@@ -219,50 +222,61 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
- ; let defn = TyData { td_ND = DataType, td_cType = Nothing
- , td_ctxt = ctxt'
- , td_kindSig = Nothing
- , td_cons = cons', td_derivs = derivs' }
+ ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+ , dd_ctxt = ctxt'
+ , dd_kindSig = Nothing
+ , dd_cons = cons', dd_derivs = derivs' }
- ; returnL $ InstD $ FamInstD
- { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
- , fid_defn = defn, fid_fvs = placeHolderNames } }}
+ ; returnL $ InstD $ DataFamInstD
+ { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+ , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs 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
- { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
- , fid_defn = defn, fid_fvs = placeHolderNames } } }
-
-cvtDec (TySynInstD tc tys rhs)
- = do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
+ ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+ , dd_ctxt = ctxt'
+ , dd_kindSig = Nothing
+ , dd_cons = [con'], dd_derivs = derivs' }
+ ; returnL $ InstD $ DataFamInstD
+ { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+ , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+
+cvtDec (TySynInstD tc eqns)
+ = do { tc' <- tconNameL tc
+ ; eqns' <- mapM (cvtTySynEqn tc') eqns
+ ; returnL $ InstD $ TyFamInstD
+ { tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
+ , tfid_group = (length eqns' /= 1)
+ , tfid_fvs = placeHolderNames } } }
+----------------
+cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
+cvtTySynEqn tc (TySynEqn lhs rhs)
+ = do { lhs' <- mapM cvtType lhs
; rhs' <- cvtType rhs
- ; returnL $ InstD $ FamInstD
- { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = tys'
- , fid_defn = TySynonym rhs', fid_fvs = placeHolderNames } } }
+ ; returnL $ TyFamInstEqn { tfie_tycon = tc
+ , tfie_pats = mkHsWithBndrs lhs'
+ , tfie_rhs = rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
- [LTyClDecl RdrName], -- Family decls
- [LFamInstDecl RdrName])
+ [LFamilyDecl RdrName],
+ [LTyFamInstDecl RdrName],
+ [LDataFamInstDecl 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 (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
+ ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
+ ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
; 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', fams', ats') }
+ ; return (listToBag binds', sigs', fams', ats', adts') }
----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
@@ -290,13 +304,17 @@ cvt_tyinst_hdr cxt tc tys
-- Partitioning declarations
-------------------------------------------------------------------
-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 :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
+is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = 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 { lid_inst = d }))) = Left (L loc d)
-is_fam_inst decl = Right decl
+is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
+is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
+is_tyfam_inst decl = Right decl
+
+is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
+is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
+is_datafam_inst decl = Right decl
is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index cd19e4c89bfa5569ad0f09108109820c51fa2de5..8ee17a52b41a4f6a872eefe56f1c57352e62a9ae 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -8,20 +8,25 @@
-- | Abstract syntax of global declarations.
--
--- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
module HsDecls (
-- * Toplevel declarations
- HsDecl(..), LHsDecl, HsTyDefn(..),
+ HsDecl(..), LHsDecl, HsDataDefn(..),
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, TyClGroup,
- isClassDecl, isDataDecl, isSynDecl, isFamilyDecl,
- isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName,
- countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour,
+ isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, tcdName,
+ tyFamInstDeclName, tyFamInstDeclLName,
+ countTyClDecls, pprTyClDeclFlavour,
+ tyClDeclLName, tyClDeclTyVars,
+ FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
- FamInstDecl(..), LFamInstDecl, instDeclFamInsts,
+ TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
+ DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
+ TyFamInstEqn(..), LTyFamInstEqn,
+ LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
@@ -275,7 +280,7 @@ instance OutputableBndr name => Outputable (SpliceDecl name) where
%************************************************************************
%* *
-\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%* *
%************************************************************************
@@ -426,24 +431,26 @@ data TyClDecl name
}
| -- | @type/data family T :: *->*@
- TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
- tcdLName :: Located name, -- type constructor
- tcdTyVars :: LHsTyVarBndrs name, -- type variables
- tcdKindSig :: Maybe (LHsKind name) -- result kind
- }
-
+ FamDecl { tcdFam :: FamilyDecl name }
- | -- | @type/data declaration
- TyDecl { tcdLName :: Located name -- ^ Type constructor
+ | -- | @type@ declaration
+ SynDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type
-- these include outer binders
+ , tcdRhs :: LHsType name -- ^ RHS of type declaration
+ , tcdFVs :: NameSet }
+
+ | -- | @data@ declaration
+ DataDecl { tcdLName :: Located name -- ^ Type constructor
+ , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an assoicated type
+ -- these include outer binders
-- Eg class T a where
-- type F a :: *
-- type F a = a -> a
-- Here the type decl for 'f' includes 'a'
-- in its tcdTyVars
- , tcdTyDefn :: HsTyDefn name
- , tcdFVs :: NameSet }
+ , tcdDataDefn :: HsDataDefn name
+ , tcdFVs :: NameSet }
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class
@@ -451,102 +458,42 @@ data TyClDecl name
tcdFDs :: [Located (FunDep name)], -- ^ Functional deps
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
- tcdATs :: [LTyClDecl name], -- ^ Associated types; ie
- -- only 'TyFamily'
- tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie
- -- only 'TySynonym'
+ tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie
+ tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: NameSet
}
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 (LHsKind name),
- -- ^ Optional kind signature.
- --
- -- @(Just k)@ for a GADT-style @data@,
- -- or @data instance@ decl, with explicit kind sig
- --
- -- Always @Nothing@ for H98-syntax decls
-
- 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 ...@
- deriving( Eq, Data, Typeable ) -- Needed because Demand derives Eq
+type LFamilyDecl name = Located (FamilyDecl name)
+data FamilyDecl name = FamilyDecl
+ { fdFlavour :: FamilyFlavour -- type or data
+ , fdLName :: Located name -- type constructor
+ , fdTyVars :: LHsTyVarBndrs name -- type variables
+ , fdKindSig :: Maybe (LHsKind name) } -- result kind
+ deriving( Data, Typeable )
data FamilyFlavour
- = TypeFamily -- ^ @type family ...@
- | DataFamily -- ^ @data family ...@
- deriving (Data, Typeable)
-\end{code}
-
-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 = HsTyDefn tvs
- This is a vanilla data type or type synonym
- tvs are the quantified type variables
+ = TypeFamily
+ | DataFamily
+ deriving( Data, Typeable )
+\end{code}
------------------------------
Simple classifiers
\begin{code}
-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 (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn
-isDataDecl _other = False
+isDataDecl (DataDecl {}) = True
+isDataDecl _other = False
-- | type or type instance declaration
isSynDecl :: TyClDecl name -> Bool
-isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn
-isSynDecl _other = False
+isSynDecl (SynDecl {}) = True
+isSynDecl _other = False
-- | type class
isClassDecl :: TyClDecl name -> Bool
@@ -555,18 +502,36 @@ isClassDecl _ = False
-- | type family declaration
isFamilyDecl :: TyClDecl name -> Bool
-isFamilyDecl (TyFamily {}) = True
+isFamilyDecl (FamDecl {}) = True
isFamilyDecl _other = False
\end{code}
Dealing with names
\begin{code}
-famInstDeclName :: LFamInstDecl a -> a
-famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name
+tyFamInstDeclName :: OutputableBndr name
+ => TyFamInstDecl name -> name
+tyFamInstDeclName = unLoc . tyFamInstDeclLName
+
+tyFamInstDeclLName :: OutputableBndr name
+ => TyFamInstDecl name -> Located name
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
+ (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
+ -- there may be more than one equation, but grab the name from the first
+ = ln
+tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
+
+tyClDeclLName :: TyClDecl name -> Located name
+tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
+tyClDeclLName decl = tcdLName decl
tcdName :: TyClDecl name -> name
-tcdName decl = unLoc (tcdLName decl)
+tcdName = unLoc . tyClDeclLName
+
+tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name
+tyClDeclTyVars decl@(ForeignType {}) = pprPanic "tyClDeclTyVars" (ppr decl)
+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVars d = tcdTyVars d
\end{code}
\begin{code}
@@ -579,11 +544,11 @@ countTyClDecls decls
count isNewTy decls, -- ...instances
count isFamilyDecl decls)
where
- isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True
- isDataTy _ = False
+ isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
+ isDataTy _ = False
- isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True
- isNewTy _ = False
+ isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
+ isNewTy _ = False
\end{code}
\begin{code}
@@ -593,20 +558,14 @@ instance OutputableBndr name
ppr (ForeignType {tcdLName = ltycon})
= hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
- ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
- tcdTyVars = tyvars, tcdKindSig = mb_kind})
- = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
- where
- pp_flavour = case flavour of
- TypeFamily -> ptext (sLit "type family")
- DataFamily -> ptext (sLit "data family")
+ ppr (FamDecl { tcdFam = decl }) = ppr decl
+ ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
+ = hang (ptext (sLit "type") <+>
+ pp_vanilla_decl_head ltycon tyvars [] <+> equals)
+ 4 (ppr rhs)
- pp_kind = case mb_kind of
- Nothing -> empty
- Just kind -> dcolon <+> ppr kind
-
- ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn })
- = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn
+ ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
+ = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
@@ -625,6 +584,19 @@ instance OutputableBndr name
<+> pp_vanilla_decl_head lclas tyvars (unLoc context)
<+> pprFundeps (map unLoc fds)
+instance (OutputableBndr name) => Outputable (FamilyDecl name) where
+ ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon,
+ fdTyVars = tyvars, fdKindSig = mb_kind})
+ = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
+ where
+ pp_kind = case mb_kind of
+ Nothing -> empty
+ Just kind -> dcolon <+> ppr kind
+
+instance Outputable FamilyFlavour where
+ ppr TypeFamily = ptext (sLit "type family")
+ ppr DataFamily = ptext (sLit "data family")
+
pp_vanilla_decl_head :: OutputableBndr name
=> Located name
-> LHsTyVarBndrs name
@@ -633,66 +605,24 @@ pp_vanilla_decl_head :: OutputableBndr name
pp_vanilla_decl_head thing tyvars context
= hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
-pp_fam_inst_head :: OutputableBndr name
+pp_fam_inst_lhs :: OutputableBndr name
=> Located name
-> HsWithBndrs [LHsType name]
-> HsContext name
-> SDoc
-pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
- = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
+pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
+ = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) typats)]
-pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
- = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
-pp_condecls cs -- In H98 syntax
- = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
-
-pp_ty_defn :: OutputableBndr name
- => (HsContext name -> SDoc) -- Printing the header
- -> HsTyDefn name
- -> SDoc
-
-pp_ty_defn pp_hdr (TySynonym { td_synRhs = 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 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")
+pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
+pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family")
+pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type")
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
+ = ppr nd
+pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
\end{code}
-
%************************************************************************
%* *
\subsection[ConDecl]{A data-constructor declaration}
@@ -700,6 +630,52 @@ pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
%************************************************************************
\begin{code}
+
+data HsDataDefn name -- The payload of a data type defn
+ -- Used *both* for vanilla data declarations,
+ -- *and* for data family instances
+ = -- | Declares a data type or newtype, giving its construcors
+ -- @
+ -- data/newtype T a = <constrs>
+ -- data/newtype instance T [a] = <constrs>
+ -- @
+ HsDataDefn { dd_ND :: NewOrData,
+ dd_ctxt :: LHsContext name, -- ^ Context
+ dd_cType :: Maybe CType,
+ dd_kindSig:: Maybe (LHsKind name),
+ -- ^ Optional kind signature.
+ --
+ -- @(Just k)@ for a GADT-style @data@,
+ -- or @data instance@ decl, with explicit kind sig
+ --
+ -- Always @Nothing@ for H98-syntax decls
+
+ dd_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'.
+
+ dd_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 ...@
+ deriving( Eq, Data, Typeable ) -- Needed because Demand derives Eq
+
type LConDecl name = Located (ConDecl name)
-- data T b = forall a. Eq a => MkT a b
@@ -774,6 +750,40 @@ instance Outputable ty => Outputable (ResType ty) where
\begin{code}
+pp_data_defn :: OutputableBndr name
+ => (HsContext name -> SDoc) -- Printing the header
+ -> HsDataDefn name
+ -> SDoc
+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+ , dd_kindSig = mb_sig
+ , dd_cons = condecls, dd_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 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 (HsDataDefn name) where
+ ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
+
+instance Outputable NewOrData where
+ ppr NewType = ptext (sLit "newtype")
+ ppr DataType = ptext (sLit "data")
+
+pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
+ = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
+pp_condecls cs -- In H98 syntax
+ = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
+
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
@@ -813,36 +823,69 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
%************************************************************************
\begin{code}
-type LFamInstDecl name = Located (FamInstDecl name)
-data FamInstDecl name
- = FamInstDecl
- { fid_tycon :: Located name
- , fid_pats :: HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs)
- -- See Note [Family instance declaration binders]
- , fid_defn :: HsTyDefn name -- Type or data family instance
- , fid_fvs :: NameSet }
+-- see note [Family instance equation groups]
+type LTyFamInstEqn name = Located (TyFamInstEqn name)
+
+-- | one equation in a family instance declaration
+data TyFamInstEqn name
+ = TyFamInstEqn
+ { tfie_tycon :: Located name
+ , tfie_pats :: HsWithBndrs [LHsType name]
+ -- ^ Type patterns (with kind and type bndrs)
+ -- See Note [Family instance declaration binders]
+ , tfie_rhs :: LHsType name }
+ deriving( Typeable, Data )
+
+type LTyFamInstDecl name = Located (TyFamInstDecl name)
+data TyFamInstDecl name
+ = TyFamInstDecl
+ { tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns
+ , tfid_group :: Bool -- was this declared with the "where" syntax?
+ , tfid_fvs :: NameSet } -- the group is type-checked as one,
+ -- so one NameSet will do
+ -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
+ deriving( Typeable, Data )
+
+type LDataFamInstDecl name = Located (DataFamInstDecl name)
+data DataFamInstDecl name
+ = DataFamInstDecl
+ { dfid_tycon :: Located name
+ , dfid_pats :: HsWithBndrs [LHsType name] -- lhs
+ -- ^ Type patterns (with kind and type bndrs)
+ -- See Note [Family instance declaration binders]
+ , dfid_defn :: HsDataDefn name -- rhs
+ , dfid_fvs :: NameSet } -- free vars for dependency analysis
deriving( Typeable, Data )
type LInstDecl name = Located (InstDecl name)
data InstDecl name -- Both class and family instances
= ClsInstD
+ { cid_inst :: ClsInstDecl name }
+ | DataFamInstD -- data family instance
+ { dfid_inst :: DataFamInstDecl name }
+ | TyFamInstD -- type family instance
+ { tfid_inst :: TyFamInstDecl name }
+ deriving (Data, Typeable)
+
+type LClsInstDecl name = Located (ClsInstDecl name)
+data ClsInstDecl name
+ = ClsInstDecl
{ 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
+ , cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances
+ , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
}
-
- | FamInstD -- type/data family instance
- { lid_inst :: 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
+A {Ty|Data}FamInstDecl is a data/type family instance declaration
+the 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
@@ -858,36 +901,69 @@ tvs are fv(pat_tys), *including* ones that are already in scope
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
+Note [Family instance equation groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyFamInstDecl contains a list of FamInstEqn's, one for each
+equation defined in the instance group. For a standalone
+instance declaration, this list contains exactly one element.
+It is not possible for this list to have 0 elements --
+'type instance where' without anything else is not allowed.
-instance (OutputableBndr name) => Outputable (InstDecl name) where
- ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds
- , cid_sigs = sigs, cid_fam_insts = ats })
+\begin{code}
+instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
+ ppr (TyFamInstDecl { tfid_group = False, tfid_eqns = [lEqn] })
+ = let eqn = unLoc lEqn in
+ ptext (sLit "type instance") <+> (ppr eqn)
+ ppr (TyFamInstDecl { tfid_eqns = eqns })
+ = hang (ptext (sLit "type instance where"))
+ 2 (vcat (map ppr eqns))
+
+instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
+ ppr (TyFamInstEqn { tfie_tycon = tycon
+ , tfie_pats = pats
+ , tfie_rhs = rhs })
+ = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
+
+instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
+ ppr (DataFamInstDecl { dfid_tycon = tycon
+ , dfid_pats = pats
+ , dfid_defn = defn })
+ = pp_data_defn ((ptext (sLit "instance") <+>) . (pp_fam_inst_lhs tycon pats)) defn
+
+pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+ = ppr nd
+
+instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
+ ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+ , cid_sigs = sigs, cid_tyfam_insts = ats
+ , cid_datafam_insts = adts })
| null sigs && null ats && isEmptyBag binds -- No "where" part
= top_matter
| otherwise -- Laid out
= vcat [ top_matter <+> ptext (sLit "where")
, nest 2 $ pprDeclList (map ppr ats ++
+ map ppr adts ++
pprLHsBindsForUser binds sigs) ]
where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
- ppr (FamInstD { lid_inst = decl }) = ppr decl
+instance (OutputableBndr name) => Outputable (InstDecl name) where
+ ppr (ClsInstD { cid_inst = decl }) = ppr decl
+ ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
+ ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
--- Extract the declarations of associated types from an instance
+-- Extract the declarations of associated data types from an instance
-instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
-instDeclFamInsts inst_decls
+instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]
+instDeclDataFamInsts inst_decls
= concatMap do_one inst_decls
where
- do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts
- do_one (L _ (FamInstD { lid_inst = fam_inst })) = [fam_inst]
+ do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
+ = map unLoc fam_insts
+ do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
+ do_one (L _ (TyFamInstD {})) = []
\end{code}
%************************************************************************
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 087ecd29853cca9a24287a08e7851aef33d9cffb..e1005b62811a92970eb1741cee7cf0422aa03e8e 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -68,7 +68,7 @@ module HsUtils(
collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
- hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
+ hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -639,32 +639,35 @@ hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
-------------------
hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
-hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name]
+hsTyClDeclBinders (FamDecl { tcdFam = FamilyDecl { fdLName = name} }) = [name]
hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
+hsTyClDeclBinders (SynDecl {tcdLName = name}) = [name]
hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
- , tcdATs = ats, tcdATDefs = fam_insts })
+ , tcdATs = ats })
= cls_name :
- concatMap hsLTyClDeclBinders ats ++
- concatMap (hsFamInstBinders . unLoc) fam_insts ++
+ map (fdLName . unLoc) ats ++
[n | L _ (TypeSig ns _) <- sigs, n <- ns]
-hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
- = name : hsTyDefnBinders defn
+hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn })
+ = name : hsDataDefnBinders defn
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
-hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
-hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi
+hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
+ = concatMap (hsDataFamInstBinders . unLoc) dfis
+hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
+hsInstDeclBinders (TyFamInstD {}) = []
-------------------
-hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
-hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
+hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
+hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+ = hsDataDefnBinders defn
+ -- There can't be repeated symbols because only data instances have binders
-------------------
-hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
-hsTyDefnBinders (TySynonym {}) = []
-hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
+hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
+hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 8226b426c39a6d8c003639faab29ca70bef4c1f3..8a110b4b333dff49ab3b22f505f7be232b48d674 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1049,7 +1049,7 @@ instance Binary LeftOrRight where
_ -> return CRight }
instance Binary IfaceCoCon where
- put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
+ put_ bh (IfaceCoAx n ind) = do { putByte bh 0; put_ bh n; put_ bh ind }
put_ bh IfaceReflCo = putByte bh 1
put_ bh IfaceUnsafeCo = putByte bh 2
put_ bh IfaceSymCo = putByte bh 3
@@ -1061,7 +1061,7 @@ instance Binary IfaceCoCon where
get bh = do
h <- getByte bh
case h of
- 0 -> do { n <- get bh; return (IfaceCoAx n) }
+ 0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) }
1 -> return IfaceReflCo
2 -> return IfaceUnsafeCo
3 -> return IfaceSymCo
@@ -1356,12 +1356,11 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
- put_ bh (IfaceAxiom a1 a2 a3 a4) = do
+ put_ bh (IfaceAxiom a1 a2 a3) = do
putByte bh 5
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
- put_ bh a4
get bh = do
h <- getByte bh
@@ -1401,9 +1400,19 @@ instance Binary IfaceDecl where
_ -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
- a4 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceAxiom occ a2 a3 a4)
+ return (IfaceAxiom occ a2 a3)
+
+instance Binary IfaceAxBranch where
+ put_ bh (IfaceAxBranch a1 a2 a3) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ return (IfaceAxBranch a1 a2 a3)
instance Binary ty => Binary (SynTyConRhs ty) where
put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b
@@ -1433,17 +1442,19 @@ instance Binary IfaceClsInst where
return (IfaceClsInst cls tys dfun flag orph)
instance Binary IfaceFamInst where
- put_ bh (IfaceFamInst fam tys name orph) = do
+ put_ bh (IfaceFamInst fam group tys name orph) = do
put_ bh fam
+ put_ bh group
put_ bh tys
put_ bh name
put_ bh orph
get bh = do
fam <- get bh
+ group <- get bh
tys <- get bh
name <- get bh
orph <- get bh
- return (IfaceFamInst fam tys name orph)
+ return (IfaceFamInst fam group tys name orph)
instance Binary OverlapFlag where
put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 2f827ca2bddb72585fa7753172e26f8f0e3a07ff..617f0f398ff8727480b849474e0a5971a6851262 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -20,7 +20,7 @@ module IfaceSyn (
IfaceBinding(..), IfaceConAlt(..),
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
- IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
+ IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceAxBranch(..),
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -102,10 +102,10 @@ data IfaceDecl
-- with the class recursive?
}
- | IfaceAxiom { ifName :: OccName -- Axiom name
- , ifTyVars :: [IfaceTvBndr] -- Axiom tyvars
- , ifLHS :: IfaceType -- Axiom LHS
- , ifRHS :: IfaceType } -- and RHS
+ | IfaceAxiom { ifName :: OccName, -- Axiom name
+ ifTyCon :: IfaceTyCon, -- LHS TyCon
+ ifAxBranches :: [IfaceAxBranch] -- Branches
+ }
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move
-- beyond .NET
@@ -126,6 +126,11 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType
-- 3. The instantiated family arguments
-- 2. The RHS of the synonym
+-- this is just like CoAxBranch
+data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
+ , ifaxbLHS :: [IfaceType]
+ , ifaxbRHS :: IfaceType }
+
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
| IfDataFamTyCon -- Data family
@@ -165,11 +170,15 @@ data IfaceClsInst
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+-- The ifFamInstTys field of IfaceFamInst contains a list of the rough
+-- match types, one per branch... but each "rough match types" is itself
+-- a list of Maybe IfaceTyCon. So, we get [[Maybe IfaceTyCon]].
data IfaceFamInst
- = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name
- , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
- , ifFamInstAxiom :: IfExtName -- The axiom
- , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst
+ = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name
+ , ifFamInstGroup :: Bool -- Is this a group?
+ , ifFamInstTys :: [[Maybe IfaceTyCon]] -- See above
+ , ifFamInstAxiom :: IfExtName -- The axiom
+ , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst
}
data IfaceRule
@@ -517,10 +526,13 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
sep (map ppr ats),
sep (map ppr sigs)])
-pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars,
- ifLHS = lhs, ifRHS = rhs})
- = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars)
- 2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs)
+pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
+ = hang (ptext (sLit "axiom") <+> ppr name <> colon)
+ 2 (vcat $ map (pprIfaceAxBranch tycon) branches)
+
+pprIfaceAxBranch :: IfaceTyCon -> IfaceAxBranch -> SDoc
+pprIfaceAxBranch tc (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs })
+ = pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tc lhs) <+> text "~#" <+> ppr rhs
pprCType :: Maybe CType -> SDoc
pprCType Nothing = ptext (sLit "No C type associated")
@@ -606,10 +618,10 @@ instance Outputable IfaceClsInst where
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
- ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
+ ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcss,
ifFamInstAxiom = tycon_ax})
= hang (ptext (sLit "family instance") <+>
- ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ ppr fam <+> pprWithCommas (brackets . pprWithCommas ppr_rough) mb_tcss)
2 (equals <+> ppr tycon_ax)
ppr_rough :: Maybe IfaceTyCon -> SDoc
@@ -787,9 +799,16 @@ freeNamesIfDecl d@IfaceClass{} =
fnList freeNamesIfAT (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
freeNamesIfDecl d@IfaceAxiom{} =
- freeNamesIfTvBndrs (ifTyVars d) &&&
- freeNamesIfType (ifLHS d) &&&
- freeNamesIfType (ifRHS d)
+ freeNamesIfTc (ifTyCon d) &&&
+ fnList freeNamesIfAxBranch (ifAxBranches d)
+
+freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
+freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
+ , ifaxbLHS = lhs
+ , ifaxbRHS = rhs }) =
+ freeNamesIfTvBndrs tyvars &&&
+ fnList freeNamesIfType lhs &&&
+ freeNamesIfType rhs
freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
@@ -920,7 +939,7 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfCo :: IfaceCoCon -> NameSet
-freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo (IfaceCoAx tc _) = unitNameSet tc
-- ToDo: include IfaceIPCoAx? Probably not necessary.
freeNamesIfCo _ = emptyNameSet
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index fd12af1f154f1afa984ac2b12cf6beff2e2388bf..103d336dbbb9934cc40a27a09d049442f6406599 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -32,6 +32,7 @@ import Coercion
import TypeRep hiding( maybeParen )
import Unique( hasKey )
import TyCon
+import CoAxiom
import Id
import Var
import TysWiredIn
@@ -89,7 +90,7 @@ newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
-- Coercion constructors
data IfaceCoCon
- = IfaceCoAx IfExtName
+ = IfaceCoAx IfExtName Int -- Int is 0-indexed branch number
| IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
| IfaceTransCo | IfaceInstCo
| IfaceNthCo Int | IfaceLRCo LeftOrRight
@@ -264,7 +265,7 @@ instance Outputable IfaceTyCon where
ppr = ppr . ifaceTyConName
instance Outputable IfaceCoCon where
- ppr (IfaceCoAx n) = ppr n
+ ppr (IfaceCoAx n i) = ppr n <> brackets (ppr i)
ppr IfaceReflCo = ptext (sLit "Refl")
ppr IfaceUnsafeCo = ptext (sLit "Unsafe")
ppr IfaceSymCo = ptext (sLit "Sym")
@@ -358,7 +359,8 @@ coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1)
coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v)
(coToIfaceType co)
coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceCoVar cv)
-coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (coAxiomToIfaceType con)
+coToIfaceType (AxiomInstCo con ind cos)
+ = IfaceCoConApp (coAxiomToIfaceType con ind)
(map coToIfaceType cos)
coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo
[ toIfaceType ty1
@@ -376,7 +378,7 @@ coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
[ coToIfaceType co
, toIfaceType ty ]
-coAxiomToIfaceType :: CoAxiom -> IfaceCoCon
-coAxiomToIfaceType con = IfaceCoAx (coAxiomName con)
+coAxiomToIfaceType :: CoAxiom br -> Int -> IfaceCoCon
+coAxiomToIfaceType con ind = IfaceCoAx (coAxiomName con) ind
\end{code}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 217dad305afba3ef01dcda7fac5edf1da0bb4423..3a0edb502c93a9675c93a81de4b4b74d182468c3 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -69,7 +69,7 @@ import CoreFVs
import Class
import Kind
import TyCon
-import Coercion ( coAxiomSplitLHS )
+import CoAxiom
import DataCon
import Type
import TcType
@@ -1438,17 +1438,24 @@ idToIfaceDecl id
--------------------------
-coAxiomToIfaceDecl :: CoAxiom -> IfaceDecl
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
-- We *do* tidy Axioms, because they are not (and cannot
-- conveniently be) built in tidy form
-coAxiomToIfaceDecl ax
- = IfaceAxiom { ifName = name
- , ifTyVars = toIfaceTvBndrs tv_bndrs
- , ifLHS = tidyToIfaceType env (coAxiomLHS ax)
- , ifRHS = tidyToIfaceType env (coAxiomRHS ax) }
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches })
+ = IfaceAxiom { ifName = name
+ , ifTyCon = toIfaceTyCon tycon
+ , ifAxBranches = brListMap coAxBranchToIfaceBranch branches }
where
name = getOccName ax
- (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv (coAxiomTyVars ax)
+
+
+coAxBranchToIfaceBranch :: CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
+ = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
+ , ifaxbLHS = map (tidyToIfaceType env) lhs
+ , ifaxbRHS = tidyToIfaceType env rhs }
+ where
+ (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv tvs
-----------------
tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl
@@ -1631,24 +1638,28 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
(n : _) -> Just (nameOccName n)
--------------------------
-famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
- fi_fam = fam,
- fi_tcs = mb_tcs })
+famInstToIfaceFamInst :: FamInst br -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
+ fi_group = group,
+ fi_fam = fam,
+ fi_branches = branches })
= IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
, ifFamInstFam = fam
- , ifFamInstTys = map do_rough mb_tcs
+ , ifFamInstGroup = group
+ , ifFamInstTys = map (map do_rough) roughs
, ifFamInstOrph = orph }
where
+ roughs = brListMap famInstBranchRoughMatch branches
+
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
- fam_decl = tyConName . fst $ coAxiomSplitLHS axiom
+ fam_decl = tyConName $ coAxiomTyCon axiom
mod = ASSERT( isExternalName (coAxiomName axiom) )
nameModule (coAxiomName axiom)
is_local name = nameIsLocalOrFrom mod name
- lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom))
+ lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
orph | is_local fam_decl
= Just (nameOccName fam_decl)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 652eb0ad11a4e2575a2ca57f9147c1b88a52f438..359013395395271aa34309b55648ee44c08beee3 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -38,6 +38,7 @@ import MkId
import IdInfo
import Class
import TyCon
+import CoAxiom
import DataCon
import PrelNames
import TysWiredIn
@@ -454,13 +455,18 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
tc_parent tyvars (Just ax_name)
= ASSERT( isNoParent parent )
do { ax <- tcIfaceCoAxiom ax_name
- ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax
- subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars)
+ ; let fam_tc = coAxiomTyCon ax
+ ax_unbr = toUnbranchedAxiom ax
+ -- data families don't have branches:
+ branch = coAxiomSingleBranch ax_unbr
+ ax_tvs = coAxBranchTyVars branch
+ ax_lhs = coAxBranchLHS branch
+ subst = zipTopTvSubst ax_tvs (mkTyVarTys tyvars)
-- The subst matches the tyvar of the TyCon
-- with those from the CoAxiom. They aren't
-- necessarily the same, since the two may be
-- gotten from separate interface-file declarations
- ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
+ ; return (FamInstTyCon ax_unbr fam_tc (substTys subst ax_lhs)) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = mb_rhs_ty,
@@ -538,19 +544,25 @@ tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
-tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs,
- ifLHS = lhs, ifRHS = rhs })
- = bindIfaceTyVars tv_bndrs $ \ tvs -> do
- { tc_name <- lookupIfaceTop tc_occ
- ; tc_lhs <- tcIfaceType lhs
- ; tc_rhs <- tcIfaceType rhs
- ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
- , co_ax_name = tc_name
- , co_ax_implicit = False
- , co_ax_tvs = tvs
- , co_ax_lhs = tc_lhs
- , co_ax_rhs = tc_rhs }
- ; return (ACoAxiom axiom) }
+tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = branches})
+ = do { tc_name <- lookupIfaceTop ax_occ
+ ; tc_tycon <- tcIfaceTyCon tc
+ ; tc_branches <- mapM tc_branch branches
+ ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
+ , co_ax_name = tc_name
+ , co_ax_tc = tc_tycon
+ , co_ax_branches = toBranchList tc_branches
+ , co_ax_implicit = False }
+ ; return (ACoAxiom axiom) }
+ where tc_branch :: IfaceAxBranch -> IfL CoAxBranch
+ tc_branch (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs })
+ = bindIfaceTyVars tv_bndrs $ \ tvs -> do
+ { tc_lhs <- mapM tcIfaceType lhs
+ ; tc_rhs <- tcIfaceType rhs
+ ; let branch = CoAxBranch { cab_tvs = tvs
+ , cab_lhs = tc_lhs
+ , cab_rhs = tc_rhs }
+ ; return branch }
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
@@ -637,13 +649,13 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedInstance cls mb_tcs' dfun oflag) }
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
-tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
- , ifFamInstAxiom = axiom_name } )
+tcIfaceFamInst :: IfaceFamInst -> IfL (FamInst Branched)
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcss
+ , ifFamInstGroup = group, ifFamInstAxiom = axiom_name } )
= do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
tcIfaceCoAxiom axiom_name
- ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
- ; return (mkImportedFamInst fam mb_tcs' axiom') }
+ ; let mb_tcss' = map (map (fmap ifaceTyConName)) mb_tcss
+ ; return (mkImportedFamInst fam group mb_tcss' axiom') }
\end{code}
@@ -953,7 +965,9 @@ tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
-tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp (IfaceCoAx n i) ts = AxiomInstCo <$> tcIfaceCoAxiom n
+ <*> pure i
+ <*> mapM tcIfaceCo ts
tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
@@ -1378,7 +1392,7 @@ tcIfaceKindCon (IfaceTc name)
_ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
-tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
; return (tyThingCoAxiom thing) }
diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
index 591419a251913b73e70ae0bf4222a6d77b50dde0..58df07cdc43860b13e22ff33c837c4f031ccccf5 100644
--- a/compiler/iface/TcIface.lhs-boot
+++ b/compiler/iface/TcIface.lhs-boot
@@ -5,7 +5,7 @@ import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnno
import TypeRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( ClsInst )
-import FamInstEnv ( FamInst )
+import FamInstEnv ( FamInst, Branched )
import CoreSyn ( CoreRule )
import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo )
import Module ( Module )
@@ -15,7 +15,7 @@ tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceFamInst :: IfaceFamInst -> IfL (FamInst Branched)
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
\end{code}
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 008a38d569202cfcec3a7d4a3fd6e0abf10c332e..40e913ee801fd12acd80d46bdc81a9807f55d949 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -181,7 +181,7 @@ module GHC (
ClsInst,
instanceDFunId,
pprInstance, pprInstanceHdr,
- pprFamInst, pprFamInstHdr,
+ pprFamInst,
-- ** Types and Kinds
Type, splitForAllTys, funResultTy,
@@ -1004,7 +1004,7 @@ getBindings = withSession $ \hsc_env ->
return $ icInScopeTTs $ hsc_IC hsc_env
-- | Return the instances for the current interactive session.
-getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst Branched])
getInsts = withSession $ \hsc_env ->
return $ ic_instances (hsc_IC hsc_env)
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 79eb8f54cb5d1e1e99fcdf7e95a001f0b4c0c10c..2e60965159ef06ce9f1be2b94f960575e748ff5d 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -122,7 +122,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 (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
+ data_info (DataDecl { tcdDataDefn = HsDataDefn {dd_cons = cs, dd_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just ds -> length ds)
data_info _ = (0,0)
@@ -133,20 +133,17 @@ 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 (FamInstD { lid_inst = d })
- = case countATDecl d of
- (tyd, dtd) -> (0,0,0,tyd,dtd)
- inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats })
+ inst_info (TyFamInstD {}) = (0,0,0,1,0)
+ inst_info (DataFamInstD {}) = (0,0,0,0,1)
+ inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
+ , cid_sigs = inst_sigs
+ , cid_tyfam_insts = ats
+ , cid_datafam_insts = adts } })
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
- case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
- (tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
(map (count_bind.unLoc) (bagToList inst_meths))),
- ss, is, tyDecl, dtDecl)
- where
- countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1)
- countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
+ ss, is, length ats, length adts)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index b5fe0fdf8608d3913ade4b6591bda50f43dbacf6..299f688359d18f72373036b67f305a2de815c05a 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 (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
+ data_info (SynDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just ds -> length ds)
data_info _ = (0,0)
@@ -158,10 +158,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
- (tyDecl, dtDecl) ->
+ (SynDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
(map (count_bind.unLoc) (bagToList inst_meths))),
- ss, is, tyDecl, dtDecl)
+ ss, is, SynDecl, dtDecl)
where
countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1)
countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index fce81da5a3855a876924c49dc2e7beaaa7e92a90..2101fb5df8996ac172c3147090104d3fcf359f2b 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -138,6 +138,7 @@ import Type
import Annotations
import Class
import TyCon
+import CoAxiom
import DataCon
import PrelNames ( gHC_PRIM, ioTyConName, printName )
import Packages hiding ( Version(..) )
@@ -455,7 +456,7 @@ lookupIfaceByModule dflags hpt pit mod
-- modules imported by this one, directly or indirectly, and are in the Home
-- Package Table. This ensures that we don't see instances from modules @--make@
-- compiled before this one, but which are not below this one.
-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst Branched])
hptInstances hsc_env want_this_module
= let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))
@@ -776,7 +777,7 @@ data ModDetails
md_exports :: [AvailInfo],
md_types :: !TypeEnv, -- ^ Local type environment for this particular module
md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module
- md_fam_insts :: ![FamInst],
+ md_fam_insts :: ![FamInst Branched],
md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules
md_anns :: ![Annotation], -- ^ Annotations present in this module: currently
-- they only annotate things also declared in this module
@@ -821,8 +822,9 @@ data ModGuts
-- ToDo: I'm unconvinced this is actually used anywhere
mg_tcs :: ![TyCon], -- ^ TyCons declared in this module
-- (includes TyCons for classes)
- mg_insts :: ![ClsInst], -- ^ Class instances declared in this module
- mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module
+ mg_insts :: ![ClsInst], -- ^ Class instances declared in this module
+ mg_fam_insts :: ![FamInst Branched],
+ -- ^ Family instances declared in this module
mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains
-- See Note [Overall plumbing for rules] in Rules.lhs
mg_binds :: !CoreProgram, -- ^ Bindings for this module
@@ -951,7 +953,7 @@ data InteractiveContext
-- ^ Variables defined automatically by the system (e.g.
-- record field selectors). See Notes [ic_sys_vars]
- ic_instances :: ([ClsInst], [FamInst]),
+ ic_instances :: ([ClsInst], [FamInst Branched]),
-- ^ All instances and family instances created during
-- this session. These are grabbed en masse after each
-- update to be sure that proper overlapping is retained.
@@ -1121,7 +1123,7 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix
- \begin{code}
+\begin{code}
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
@@ -1281,7 +1283,7 @@ extras_plus thing = thing : implicitTyThings thing
-- For newtypes (only) add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
- | Just co <- newTyConCo_maybe tc = [ACoAxiom co]
+ | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
| otherwise = []
-- | Returns @True@ if there should be no interface-file declaration
@@ -1353,7 +1355,7 @@ type TypeEnv = NameEnv TyThing
emptyTypeEnv :: TypeEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvTyCons :: TypeEnv -> [TyCon]
-typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
typeEnvClasses :: TypeEnv -> [Class]
@@ -1377,7 +1379,7 @@ mkTypeEnvWithImplicits things =
`plusNameEnv`
mkTypeEnv (concatMap implicitTyThings things)
-typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv
typeEnvFromEntities ids tcs famInsts =
mkTypeEnv ( map AnId ids
++ map ATyCon all_tcs
@@ -1418,7 +1420,8 @@ lookupType dflags hpt pte name
-- in one-shot, we don't use the HPT
| not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg
= do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad
- lookupNameEnv (md_types (hm_details hm)) name
+ x <- lookupNameEnv (md_types (hm_details hm)) name
+ return x
| otherwise
= lookupNameEnv pte name
where
@@ -1443,7 +1446,7 @@ tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
-tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom :: TyThing -> CoAxiom Branched
tyThingCoAxiom (ACoAxiom ax) = ax
tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 0ea01d58c22b82e75c257fbf9c5203490354df40..39ccd62551c2759dc0b471b9c4cc7a37beca175a 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -153,7 +153,7 @@ mkBootModDetailsTc hsc_env
}
where
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv
mkBootTypeEnv exports ids tcs fam_insts
= tidyTypeEnv True $
typeEnvFromEntities final_ids tcs fam_insts
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 510d7c42aeb61f4ca988eeca9e70af38a187485c..e3f49941660c790b9a1e6493cd27eb08524a0b4d 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -642,7 +642,8 @@ ty_decl :: { LTyClDecl RdrName }
| 'type' 'family' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
+ {% do { L loc decl <- mkFamDecl (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4)
+ ; return (L loc (FamDecl decl)) } }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
@@ -662,26 +663,30 @@ ty_decl :: { LTyClDecl RdrName }
-- data/newtype family
| 'data' 'family' type opt_kind_sig
- {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
+ {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4)
+ ; return (L loc (FamDecl decl)) } }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
- { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
- in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds
- , cid_sigs = sigs, cid_fam_insts = ats }) }
+ { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in
+ let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds
+ , cid_sigs = sigs, cid_tyfam_insts = ats
+ , cid_datafam_insts = adts }
+ in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) }
-- 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 <- mkFamInstSynonym (comb2 $1 $5) $3 $5
- ; return (L loc (FamInstD { lid_inst = d })) } }
+ | 'type' 'instance' ty_fam_inst_eqn
+ {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3
+ ; return (L loc (TyFamInstD { tfid_inst = tfi })) } }
+
+ | 'type' 'instance' 'where' ty_fam_inst_eqn_list
+ { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
- ; return (L loc (FamInstD { lid_inst = d })) } }
+ ; return (L loc (DataFamInstD { dfid_inst = d })) } }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
@@ -689,8 +694,25 @@ inst_decl :: { LInstDecl RdrName }
deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
- ; return (L loc (FamInstD { lid_inst = d })) } }
+ ; return (L loc (DataFamInstD { dfid_inst = d })) } }
+-- Type instance groups
+
+ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
+ : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) }
+ | vocurly ty_fam_inst_eqns close { $2 }
+
+ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
+ : ty_fam_inst_eqn ';' ty_fam_inst_eqns { LL ($1 : unLoc $3) }
+ | ty_fam_inst_eqns ';' { LL (unLoc $1) }
+ | ty_fam_inst_eqn { LL [$1] }
+
+ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
+ : type '=' ctype
+ -- Note the use of type for the head; this allows
+ -- infix type constructors and type patterns
+ {% mkTyFamInstEqn (comb2 $1 $3) $1 $3 }
+
-- Associated type family declarations
--
-- * They have a different syntax than on the toplevel (no family special
@@ -705,31 +727,32 @@ at_decl_cls :: { LHsDecl RdrName }
: 'type' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared.
- {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
- ; return (L loc (TyClD decl)) } }
+ {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
+ ; return (L loc (TyClD (FamDecl decl))) } }
| 'data' type opt_kind_sig
- {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
- ; return (L loc (TyClD decl)) } }
+ {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
+ ; return (L loc (TyClD (FamDecl decl))) } }
-- default type instance
- | 'type' type '=' ctype
+ | 'type' ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
- ; return (L loc (InstD (FamInstD { lid_inst = fid }))) } }
+ {% do { L loc tfi <- mkTyFamInst (comb2 $1 $2) $2
+ ; return (L loc (InstD (TyFamInstD { tfid_inst = tfi }))) } }
-- Associated type instances
--
-at_decl_inst :: { LFamInstDecl RdrName }
+at_decl_inst :: { LTyFamInstDecl RdrName }
-- type instance declarations
- : 'type' type '=' ctype
+ : 'type' ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% mkFamInstSynonym (comb2 $1 $4) $2 $4 }
+ {% mkTyFamInst (comb2 $1 $2) $2 }
+adt_decl_inst :: { LDataFamInstDecl RdrName }
-- data/newtype instance declaration
- | data_or_newtype capi_ctype tycl_hdr constrs deriving
+ : data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
@@ -808,7 +831,8 @@ 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 (InstD (FamInstD { lid_inst = unLoc $1 })))) }
+decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (TyFamInstD { tfid_inst = unLoc $1 })))) }
+ | adt_decl_inst { LL (unitOL (L1 (InstD (DataFamInstD { dfid_inst = unLoc $1 })))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index fbcc98346bcbfe1342710f1d80459fa26d2acda0..0e78794515a7862f05758e87c3ad3e223e13f059 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 '}' ';'
- { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
- , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
- , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc []
- , td_kindSig = Nothing
- , td_cons = $6, td_derivs = Nothing } } }
+ { DataDecl { tcdLName = noLoc (ifaceExtRdrName $2)
+ , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
+ , tcdDataDefn = HsDataDefn { dd_ND = DataType, dd_ctxt = noLoc []
+ , dd_kindSig = Nothing
+ , dd_cons = $6, dd_derivs = Nothing } } }
| '%newtype' q_tc_name tv_bndrs trep ';'
{ let tc_rdr = ifaceExtRdrName $2 in
- TyDecl { tcdLName = noLoc tc_rdr
- , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
- , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
- , td_kindSig = Nothing
- , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
+ DataDecl { tcdLName = noLoc tc_rdr
+ , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
+ , tcdDataDefn = HsDataDefn { dd_ND = NewType, dd_ctxt = noLoc []
+ , dd_kindSig = Nothing
+ , dd_cons = $4 (rdrNameOcc tc_rdr), dd_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 5c0d3bb700e28f4a4afe07c4599845eb7153bdc8..f1fa5a44b6555c29fea8612d7a9b128c41618714 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -10,8 +10,9 @@ module RdrHsSyn (
mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl,
mkTyData, mkFamInstData,
- mkTySynonym, mkFamInstSynonym,
- mkTyFamily,
+ mkTySynonym, mkTyFamInstEqn, mkTyFamInstGroup,
+ mkTyFamInst,
+ mkFamDecl,
splitCon, mkInlinePragma,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyLit,
@@ -112,7 +113,7 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl RdrName)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
- = do { let (binds, sigs, ats, at_defs, docs) = cvBindsAndSigs (unLoc where_cls)
+ = 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
@@ -133,9 +134,9 @@ 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 })) }
+ ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
+ tcdDataDefn = defn,
+ tcdFVs = placeHolderNames })) }
mkFamInstData :: SrcSpan
-> NewOrData
@@ -144,12 +145,12 @@ mkFamInstData :: SrcSpan
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
- -> P (LFamInstDecl RdrName)
+ -> P (LDataFamInstDecl 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 = mkHsWithBndrs tparams
- , fid_defn = defn, fid_fvs = placeHolderNames })) }
+ ; return (L loc (DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
+ , dfid_defn = defn, dfid_fvs = placeHolderNames })) }
mkDataDefn :: NewOrData
-> Maybe CType
@@ -157,15 +158,15 @@ mkDataDefn :: NewOrData
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
- -> P (HsTyDefn RdrName)
+ -> P (HsDataDefn RdrName)
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
- ; return (TyData { td_ND = new_or_data, td_cType = cType
- , td_ctxt = cxt
- , td_cons = data_cons
- , td_kindSig = ksig
- , td_derivs = maybe_deriv }) }
+ ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = cxt
+ , dd_cons = data_cons
+ , dd_kindSig = ksig
+ , dd_derivs = maybe_deriv }) }
mkTySynonym :: SrcSpan
-> LHsType RdrName -- LHS
@@ -174,29 +175,42 @@ mkTySynonym :: SrcSpan
mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars lhs tparams
- ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
- tcdTyDefn = TySynonym { td_synRhs = rhs },
- tcdFVs = placeHolderNames })) }
-
-mkFamInstSynonym :: SrcSpan
- -> LHsType RdrName -- LHS
- -> LHsType RdrName -- RHS
- -> P (LFamInstDecl RdrName)
-mkFamInstSynonym loc lhs rhs
+ ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars,
+ tcdRhs = rhs, tcdFVs = placeHolderNames })) }
+
+mkTyFamInstEqn :: SrcSpan
+ -> LHsType RdrName
+ -> LHsType RdrName
+ -> P (LTyFamInstEqn RdrName)
+mkTyFamInstEqn loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
- ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
- , fid_defn = TySynonym { td_synRhs = rhs }
- , fid_fvs = placeHolderNames })) }
-
-mkTyFamily :: SrcSpan
- -> FamilyFlavour
- -> LHsType RdrName -- LHS
- -> Maybe (LHsKind RdrName) -- Optional kind signature
- -> P (LTyClDecl RdrName)
-mkTyFamily loc flavour lhs ksig
+ ; return (L loc (TyFamInstEqn { tfie_tycon = tc
+ , tfie_pats = mkHsWithBndrs tparams
+ , tfie_rhs = rhs })) }
+
+mkTyFamInst :: SrcSpan
+ -> LTyFamInstEqn RdrName
+ -> P (LTyFamInstDecl RdrName)
+mkTyFamInst loc eqn
+ = return (L loc (TyFamInstDecl { tfid_eqns = [eqn]
+ , tfid_group = False
+ , tfid_fvs = placeHolderNames }))
+
+mkTyFamInstGroup :: [LTyFamInstEqn RdrName]
+ -> TyFamInstDecl RdrName
+mkTyFamInstGroup eqns = TyFamInstDecl { tfid_eqns = eqns
+ , tfid_group = True
+ , tfid_fvs = placeHolderNames }
+
+mkFamDecl :: SrcSpan
+ -> FamilyFlavour
+ -> LHsType RdrName -- LHS
+ -> Maybe (LHsKind RdrName) -- Optional kind signature
+ -> P (LFamilyDecl RdrName)
+mkFamDecl loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars lhs tparams
- ; return (L loc (TyFamily flavour tc tyvars ksig)) }
+ ; return (L loc (FamilyDecl flavour tc tyvars ksig)) }
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- If the user wrote
@@ -249,30 +263,32 @@ cvTopDecls decls = go (fromOL decls)
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, fam_ds, fam_insts, _)
- -> ASSERT( null fam_ds && null fam_insts )
+ (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _)
+ -> ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag ( LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]
- , [LFamInstDecl RdrName], [LDocDecl])
+ -> (Bag ( LHsBind RdrName), [LSig RdrName], [LFamilyDecl RdrName]
+ , [LTyFamInstDecl RdrName], [LDataFamInstDecl 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, fis, docs)
- where (bs, ss, ts, fis, docs) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, fis, docs)
+ go [] = (emptyBag, [], [], [], [], [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
+ where (bs, ss, ts, tfis, dfis, docs) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
where (b', ds') = getMonoBind (L l b) ds
- (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 { lid_inst = 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
+ (bs, ss, ts, tfis, dfis, docs) = go ds'
+ go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
+ where (bs, ss, ts, tfis, dfis, docs) = go ds
+ go (L l (InstD (TyFamInstD { tfid_inst = tfi })) : ds) = (bs, ss, ts, L l tfi : tfis, dfis, docs)
+ where (bs, ss, ts, tfis, dfis, docs) = go ds
+ go (L l (InstD (DataFamInstD { dfid_inst = dfi })) : ds) = (bs, ss, ts, tfis, L l dfi : dfis, docs)
+ where (bs, ss, ts, tfis, dfis, docs) = go ds
+ go (L l (DocD d) : ds) = (bs, ss, ts, tfis, dfis, (L l d) : docs)
+ where (bs, ss, ts, tfis, dfis, docs) = go ds
go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
-----------------------------------------------------------------------------
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index ca78368123f60e831208e85dd76ef69b9f0d9aa3..e4d21bd23bc8472ba89c41f7bcc4d86e73d29704 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -531,21 +531,26 @@ getLocalNonValBinders fixity_env
; return (AvailTC main_name names) }
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
- new_assoc (L _ (FamInstD { lid_inst = d }))
- = do { avail <- new_ti Nothing d
+ new_assoc (L _ (TyFamInstD {})) = return []
+ -- type instances don't bind new names
+
+ new_assoc (L _ (DataFamInstD { dfid_inst = d }))
+ = do { avail <- new_di Nothing d
; return [avail] }
- new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
+ new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
+ { cid_poly_ty = inst_ty
+ , cid_datafam_insts = adts } }))
| 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 }
+ ; mapM (new_di (Just cls_nm) . unLoc) adts }
| otherwise
= return [] -- Do not crash on ill-formed instances
-- Eg instance !Show Int Trac #3811c
- new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
- new_ti mb_cls ti_decl -- ONLY for type/data instances
- = do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl)
- ; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl)
+ new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo
+ new_di mb_cls ti_decl
+ = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
+ ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders 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 e6abf7bd41180e31fe4a4d79ad0bae180c8ed45e..54cd9a2bcb7d62c7e412db20652bc56d591ac069 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -418,17 +418,28 @@ patchCCallTarget packageId callTarget =
\begin{code}
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (FamInstD { lid_inst = fi })
- = do { (fi', fvs) <- rnFamInstDecl Nothing fi
- ; return (FamInstD { lid_inst = fi' }, fvs) }
-
-rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
- , cid_sigs = uprags, cid_fam_insts = ats })
+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
+ = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
+ ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
+
+rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
+ = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
+ ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
+
+rnSrcInstDecl (ClsInstD { cid_inst = cid })
+ = do { (cid', fvs) <- rnClsInstDecl cid
+ ; return (ClsInstD { cid_inst = cid' }, fvs) }
+
+rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+ , cid_sigs = uprags, cid_tyfam_insts = ats
+ , cid_datafam_insts = adts })
-- Used for both source and interface file decls
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
- Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
- , cid_sigs = [], cid_fam_insts = [] }
+ Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
+ , cid_sigs = [], cid_tyfam_insts = []
+ , cid_datafam_insts = [] }
, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
@@ -438,12 +449,13 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
-- Rename the associated types, and type signatures
-- Both need to have the instance type variables in scope
; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
- ; ((ats', other_sigs'), more_fvs)
+ ; ((ats', adts', other_sigs'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
- do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats
+ do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
+ ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
- ; return ( (ats', other_sigs')
- , at_fvs `plusFV` sig_fvs) }
+ ; return ( (ats', adts', other_sigs')
+ , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
@@ -467,8 +479,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` spec_inst_fvs
`plusFV` inst_fvs
- ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
- , cid_sigs = uprags', cid_fam_insts = ats' },
+ ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
+ , cid_sigs = uprags', cid_tyfam_insts = ats'
+ , cid_datafam_insts = adts' },
all_fvs) } } }
-- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations
@@ -481,10 +494,14 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
-- 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 = HsWB { hswb_cts = pats }
- , fid_defn = defn })
+rnFamInstDecl :: HsDocContext
+ -> Maybe (Name, [Name])
+ -> Located RdrName
+ -> [LHsType RdrName]
+ -> rhs
+ -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+ -> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars)
+rnFamInstDecl doc mb_cls tycon pats payload rnPayload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -498,11 +515,11 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
-- All the free vars of the family patterns
-- with a sensible binding location
- ; ((pats', defn'), fvs)
- <- bindLocalNamesFV kv_names $
- bindLocalNamesFV tv_names $
- do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
- ; (defn', rhs_fvs) <- rnTyDefn tycon defn
+ ; ((pats', payload'), fvs)
+ <- bindLocalNamesFV kv_names $
+ bindLocalNamesFV tv_names $
+ do { (pats', pat_fvs) <- rnLHsTypes doc pats
+ ; (payload', rhs_fvs) <- rnPayload doc payload
-- See Note [Renaming associated types]
; let bad_tvs = case mb_cls of
@@ -511,42 +528,80 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
; unless (null bad_tvs) (badAssocRhs bad_tvs)
- ; return ((pats', defn'), rhs_fvs `plusFV` pat_fvs) }
-
+ ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+
; let all_fvs = fvs `addOneFV` unLoc tycon'
- ; return ( FamInstDecl { fid_tycon = tycon'
- , fid_pats = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
- , fid_defn = defn', fid_fvs = all_fvs }
- , all_fvs ) }
+ ; return (tycon',
+ HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names },
+ payload',
+ all_fvs) }
-- type instance => use, hence addOneFV
+
+rnTyFamInstDecl :: Maybe (Name, [Name])
+ -> TyFamInstDecl RdrName
+ -> RnM (TyFamInstDecl Name, FreeVars)
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group })
+ = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns
+ ; return (TyFamInstDecl { tfid_eqns = eqns'
+ , tfid_group = group
+ , tfid_fvs = fvs }, fvs) }
+
+rnTyFamInstEqn :: Maybe (Name, [Name])
+ -> TyFamInstEqn RdrName
+ -> RnM (TyFamInstEqn Name, FreeVars)
+rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon
+ , tfie_pats = HsWB { hswb_cts = pats }
+ , tfie_rhs = rhs })
+ = do { (tycon', pats', rhs', fvs) <-
+ rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
+ ; return (TyFamInstEqn { tfie_tycon = tycon'
+ , tfie_pats = pats'
+ , tfie_rhs = rhs' }, fvs) }
+
+rnDataFamInstDecl :: Maybe (Name, [Name])
+ -> DataFamInstDecl RdrName
+ -> RnM (DataFamInstDecl Name, FreeVars)
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
+ , dfid_pats = HsWB { hswb_cts = pats }
+ , dfid_defn = defn })
+ = do { (tycon', pats', defn', fvs) <-
+ rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
+ ; return (DataFamInstDecl { dfid_tycon = tycon'
+ , dfid_pats = pats'
+ , dfid_defn = defn'
+ , dfid_fvs = fvs }, fvs) }
\end{code}
Renaming of the associated types in instances.
\begin{code}
+-- rename associated type family decl in class
rnATDecls :: Name -- Class
-> LHsTyVarBndrs Name
- -> [LTyClDecl RdrName]
- -> RnM ([LTyClDecl Name], FreeVars)
+ -> [LFamilyDecl RdrName]
+ -> RnM ([LFamilyDecl Name], FreeVars)
rnATDecls cls hs_tvs at_decls
- = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls
+ = rnList (rnFamDecl (Just (cls, tv_ns))) at_decls
where
tv_ns = hsLTyVarNames hs_tvs
-- Type variable binders (but NOT kind variables)
-- See Note [Renaming associated types] in RnTypes
-rnATInstDecls :: Name -- Class
+rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
+ decl RdrName -> -- an instance. rnTyFamInstDecl
+ RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
+ -> Name -- Class
-> LHsTyVarBndrs Name
- -> [LFamInstDecl RdrName]
- -> RnM ([LFamInstDecl Name], FreeVars)
--- Used for the family declarations and defaults in a class decl
+ -> [Located (decl RdrName)]
+ -> RnM ([Located (decl Name)], FreeVars)
+-- Used for data and type family 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
-rnATInstDecls cls hs_tvs at_insts
- = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts
+rnATInstDecls rnFun cls hs_tvs at_insts
+ = rnList (rnFun (Just (cls, tv_ns))) at_insts
where
tv_ns = hsLTyVarNames hs_tvs
-- Type variable binders (but NOT kind variables)
@@ -820,7 +875,7 @@ rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]]
-> RnM ([[LTyClDecl Name]], FreeVars)
-- Rename the declarations and do depedency analysis on them
rnTyClDecls extra_deps tycl_ds
- = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds)
+ = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
; thisPkg <- fmap thisPackage getDynFlags
; let add_boot_deps :: FreeVars -> FreeVars
-- See Note [Extra dependencies from .hs-boot files]
@@ -840,13 +895,9 @@ rnTyClDecls extra_deps tycl_ds
; return (map flattenSCC sccs, all_fvs) }
-rnTyClDecl :: Maybe (Name, [Name])
- -- Just (cls,tvs) => this TyClDecl is nested
- -- inside an *instance decl* for cls
- -- used for associated types
- -> TyClDecl RdrName
+rnTyClDecl :: TyClDecl RdrName
-> RnM (TyClDecl Name, FreeVars)
-rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
+rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= do { name' <- lookupLocatedTopBndrRn name
; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs) }
@@ -854,32 +905,37 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
-- All flavours of type family declarations ("type family", "newtype family",
-- and "data family"), both top level and (for an associated type)
-- in a class decl
-rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
- , tcdFlavour = flav, tcdKindSig = kind })
- = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
- do { tycon' <- lookupLocatedTopBndrRn tycon
- ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
- ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
- , tcdFlavour = flav, tcdKindSig = kind' }
- , fv_kind ) }
- where
- fmly_doc = TyFamilyCtx tycon
- kvs = extractRdrKindSigVars kind
+rnTyClDecl (FamDecl { tcdFam = decl })
+ = do { (decl', fvs) <- rnFamDecl Nothing decl
+ ; return (FamDecl decl', fvs) }
+
+rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
+ = do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; let kvs = fst (extractHsTyRdrTyVars rhs)
+ doc = TySynCtx tycon
+ ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+ ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
+ \ tyvars' ->
+ do { (rhs', fvs) <- rnTySyn doc rhs
+ ; return ((tyvars', rhs'), fvs) }
+ ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
+ , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
-rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
= do { tycon' <- lookupLocatedTopBndrRn tycon
- ; let kvs = extractTyDefnKindVars defn
- ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
- ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
- do { (defn', fvs) <- rnTyDefn tycon defn
+ ; let kvs = extractDataDefnKindVars defn
+ doc = TyDataCtx tycon
+ ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
+ ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
+ do { (defn', fvs) <- rnDataDefn doc defn
; return ((tyvars', defn'), fvs) }
- ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
- , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
+ ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
+ , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
-rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
- tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
tcdDocs = docs})
= do { lcls' <- lookupLocatedTopBndrRn lcls
@@ -889,13 +945,13 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
- <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
- -- Checks for distinct tyvars
+ <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds (docOfHsDocContext cls_doc) fds
-- The fundeps have no free variables
; (ats', fv_ats) <- rnATDecls cls' tyvars' ats
- ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs
+ ; (at_defs', fv_at_defs) <- rnATInstDecls rnTyFamInstDecl cls' tyvars' at_defs
; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
; let fvs = cxt_fvs `plusFV`
sig_fvs `plusFV`
@@ -942,16 +998,19 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
where
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
+-- "type" and "type instance" declarations
+rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnTySyn doc rhs = rnLHsType doc rhs
+
+rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = context, dd_cons = condecls
+ , dd_kindSig = sig, dd_derivs = derivs })
+ = do { checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta doc)
+
+ ; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
+ ; (context', fvs1) <- rnContext doc context
; (derivs', fvs3) <- rn_derivs derivs
-- For the constructor declarations, drop the LocalRdrEnv
@@ -967,9 +1026,9 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
- ; return ( TyData { td_ND = new_or_data, td_cType = cType
- , td_ctxt = context', td_kindSig = sig'
- , td_cons = condecls', td_derivs = derivs' }
+ ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = context', dd_kindSig = sig'
+ , dd_cons = condecls', dd_derivs = derivs' }
, all_fvs )
}
where
@@ -977,24 +1036,33 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
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
+ rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes 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 :: HsDocContext -> SDoc
badGadtStupidTheta _
= vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
ptext (sLit "(You can put a context on each contructor, though.)")]
+
+rnFamDecl :: Maybe (Name, [Name])
+ -- Just (cls,tvs) => this FamilyDecl is nested
+ -- inside an *class decl* for cls
+ -- used for associated types
+ -> FamilyDecl RdrName
+ -> RnM (FamilyDecl Name, FreeVars)
+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
+ , fdFlavour = flav, fdKindSig = kind })
+ = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
+ ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
+ , fdFlavour = flav, fdKindSig = kind' }
+ , fv_kind ) }
+ where
+ fmly_doc = TyFamilyCtx tycon
+ kvs = extractRdrKindSigVars kind
+
\end{code}
Note [Stupid theta]
@@ -1027,11 +1095,11 @@ depAnalTyClDecls ds_w_fvs
(L _ d, _) <- ds_w_fvs
case d of
ClassDecl { tcdLName = L _ cls_name
- , tcdATs = ats }
- -> do L _ assoc_decl <- ats
- return (tcdName assoc_decl, cls_name)
- TyDecl { tcdLName = L _ data_name
- , tcdTyDefn = TyData { td_cons = cons } }
+ , tcdATs = ats }
+ -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
+ return (fam_name, cls_name)
+ DataDecl { tcdLName = L _ data_name
+ , tcdDataDefn = HsDataDefn { dd_cons = cons } }
-> do L _ dc <- cons
return (unLoc (con_name dc), data_name)
_ -> []
@@ -1224,10 +1292,10 @@ extendRecordFieldEnv tycl_decls inst_decls
; return $ unLoc x'}
all_data_cons :: [ConDecl RdrName]
- all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs
+ all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
, L _ con <- cons ]
- all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ]
- ++ map fid_defn (instDeclFamInsts inst_decls) -- Do not forget associated types!
+ all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- concat tycl_decls ]
+ ++ map dfid_defn (instDeclDataFamInsts 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 b515f3adf0dcd503427c7adb4ba5b2965569a760..eb78f0f15b40e29314a93c307335e7203a9ca5b3 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -28,7 +28,7 @@ module RnTypes (
-- Binding related stuff
bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
- extractRdrKindSigVars, extractTyDefnKindVars, filterInScope
+ extractRdrKindSigVars, extractDataDefnKindVars, filterInScope
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -958,14 +958,12 @@ extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
extractRdrKindSigVars Nothing = []
extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
-extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName]
+extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
-- Get the scoped kind variables mentioned free in the constructor decls
-- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
-- Here k should scope over the whole definition
-extractTyDefnKindVars (TySynonym { td_synRhs = ty})
- = fst (extractHsTyRdrTyVars ty)
-extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig
- , td_cons = cons, td_derivs = derivs })
+extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
+ , dd_cons = cons, dd_derivs = derivs })
= fst $ extract_lctxt ctxt $
extract_mb extract_lkind ksig $
extract_mb extract_ltys derivs $
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 45ef02657ee0ff850c75ac5accd17bc540676898..b6801981504f3ba000efdb14bee5e62b1767a2a0 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -18,17 +18,19 @@ import HscTypes
import FamInstEnv
import LoadIface
import TypeRep
-import TcMType
import TcRnMonad
import TyCon
+import CoAxiom
import DynFlags
-import Name
import Module
import Outputable
import UniqFM
import FastString
import Util
import Maybes
+import TcMType
+import Type
+import VarSet (mkVarSet)
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
@@ -169,7 +171,7 @@ then we have a coercion (ie, type instance of family instance coercion)
which implies that :R42T was declared as 'data instance T [a]'.
\begin{code}
-tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (FamInst, [Type]))
+tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
tcLookupFamInst tycon tys
| not (isFamilyTyCon tycon)
= return Nothing
@@ -181,8 +183,8 @@ tcLookupFamInst tycon tys
-- ppr mb_match $$ ppr instEnv)
; case mb_match of
[] -> return Nothing
- ((fam_inst, rep_tys):_)
- -> return $ Just (fam_inst, rep_tys)
+ (match:_)
+ -> return $ Just match
}
tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -196,8 +198,12 @@ tcLookupDataFamInst tycon tys
do { maybeFamInst <- tcLookupFamInst tycon tys
; case maybeFamInst of
Nothing -> famInstNotFound tycon tys
- Just (famInst, tys) -> let tycon' = dataFamInstRepTyCon famInst
- in return (tycon', tys) }
+ Just (FamInstMatch { fim_instance = famInst
+ , fim_index = index
+ , fim_tys = tys })
+ -> ASSERT( index == 0 )
+ let tycon' = dataFamInstRepTyCon famInst
+ in return (tycon', tys) }
famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys
@@ -238,7 +244,7 @@ with standalone deriving declrations.
\begin{code}
-- Add new locally-defined family instances
-tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
+tcExtendLocalFamInstEnv :: [FamInst br] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
= do { env <- getGblEnv
; (inst_env', fam_insts') <- foldlM addLocalFamInst
@@ -251,32 +257,87 @@ tcExtendLocalFamInstEnv fam_insts thing_inside
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst])
-addLocalFamInst (home_fie, my_fis) fam_inst
+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
+-- in FamInstEnv.lhs
+addLocalFamInst :: (FamInstEnv,[FamInst Branched]) -> FamInst br -> TcM (FamInstEnv, [FamInst Branched])
+addLocalFamInst (home_fie, my_fis) fam_inst
-- home_fie includes home package and this module
-- my_fies is just the ones from this module
= do { traceTc "addLocalFamInst" (ppr fam_inst)
+
+ -- We wish to extend the instance envt with completely
+ -- fresh template variables. Otherwise, there may be
+ -- problems when we try to unify the template variables
+ -- with type family applications.
+
+ -- See also addLocalInst in Inst.lhs
+ ; (axBranches', fiBranches')
+ <- zipWithAndUnzipM mk_skolem_tyvars (fromBranchList $ coAxiomBranches axiom)
+ (fromBranchList fiBranches)
+ ; let axiom' = axiom { co_ax_branches = toBranchList axBranches' }
+ fam_inst' = fam_inst { fi_axiom = axiom'
+ , fi_branches = toBranchList fiBranches' }
+
; isGHCi <- getIsGHCi
-- In GHCi, we *override* any identical instances
-- that are also defined in the interactive context
; let (home_fie', my_fis')
- | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst
- , filterOut (identicalFamInst fam_inst) my_fis)
+ | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst'
+ , filterOut (identicalFamInst fam_inst') my_fis)
| otherwise = (home_fie, my_fis)
-- Load imported instances, so that we report
-- overlaps correctly
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie')
- home_fie'' = extendFamInstEnv home_fie fam_inst
+ home_fie'' = extendFamInstEnv home_fie fam_inst'
-- Check for conflicting instance decls
- ; no_conflict <- checkForConflicts inst_envs fam_inst
+ ; no_conflict <- checkForConflicts inst_envs fam_inst'
; if no_conflict then
- return (home_fie'', fam_inst : my_fis')
+ return (home_fie'', fam_inst' : my_fis')
else
return (home_fie, my_fis) }
+
+ where
+ axiom = famInstAxiom fam_inst
+ fiBranches = famInstBranches fam_inst
+
+ zipWithAndUnzipM :: Monad m
+ => (a -> b -> m (c, d))
+ -> [a]
+ -> [b]
+ -> m ([c], [d])
+ zipWithAndUnzipM f as bs
+ = do { cds <- zipWithM f as bs
+ ; return $ unzip cds }
+
+ mk_skolem_tyvars :: CoAxBranch -> FamInstBranch
+ -> TcM (CoAxBranch, FamInstBranch)
+ mk_skolem_tyvars axb fib
+ = do { (subst, skol_tvs) <- tcInstSkolTyVars (coAxBranchTyVars axb)
+ ; let axb' = coAxBranchSubst axb skol_tvs subst
+ fib' = famInstBranchSubst fib skol_tvs subst
+ ; return (axb', fib') }
+
+ -- substitute the tyvars for a new set of tyvars
+ coAxBranchSubst :: CoAxBranch -> [TyVar] -> TvSubst -> CoAxBranch
+ coAxBranchSubst (CoAxBranch { cab_lhs = lhs
+ , cab_rhs = rhs }) new_tvs subst
+ = CoAxBranch { cab_tvs = new_tvs
+ , cab_lhs = substTys subst lhs
+ , cab_rhs = substTy subst rhs }
+
+ -- substitute the current set of tyvars for another
+ famInstBranchSubst :: FamInstBranch -> [TyVar] -> TvSubst -> FamInstBranch
+ famInstBranchSubst fib@(FamInstBranch { fib_lhs = lhs
+ , fib_rhs = rhs }) new_tvs subst
+ = fib { fib_tvs = mkVarSet new_tvs
+ , fib_lhs = substTys subst lhs
+ , fib_rhs = substTy subst rhs }
+
+
\end{code}
%************************************************************************
@@ -289,35 +350,39 @@ Check whether a single family instance conflicts with those in two instance
environments (one for the EPS and one for the HPT).
\begin{code}
-checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
-checkForConflicts inst_envs fam_inst
- = do { -- To instantiate the family instance type, extend the instance
- -- envt with completely fresh template variables
- -- This is important because the template variables must
- -- not overlap with anything in the things being looked up
- -- (since we do unification).
- -- We use tcInstSkolType because we don't want to allocate
- -- fresh *meta* type variables.
-
- ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst))
- ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs
- no_conflicts = null conflicts
+checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool
+checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches
+ , fi_group = group })
+ = do { let conflicts = brListMap (lookupFamInstEnvConflicts inst_envs group fam_tc) branches
+ no_conflicts = all null conflicts
; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
; unless no_conflicts $
- conflictInstErr fam_inst (fst (head conflicts))
+ zipWithM_ (conflictInstErr fam_inst) (fromBranchList branches) conflicts
; return no_conflicts }
+ where fam_tc = famInstTyCon fam_inst
-conflictInstErr :: FamInst -> FamInst -> TcRn ()
-conflictInstErr famInst conflictingFamInst
+conflictInstErr :: FamInst Branched -> FamInstBranch -> [FamInstMatch] -> TcRn ()
+conflictInstErr fam_inst branch conflictingMatch
+ | (FamInstMatch { fim_instance = confInst
+ , fim_index = confIndex }) : _ <- conflictingMatch
= addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
- [famInst, conflictingFamInst]
+ [(fam_inst, branch),
+ (confInst, famInstNthBranch confInst confIndex)]
+ | otherwise
+ = pprPanic "conflictInstErr" (pprFamInstBranch (famInstTyCon fam_inst) branch)
-addFamInstsErr :: SDoc -> [FamInst] -> TcRn ()
+addFamInstsErr :: SDoc -> [(FamInst Branched, FamInstBranch)] -> TcRn ()
addFamInstsErr herald insts
- = setSrcSpan (getSrcSpan (head sorted)) $
- addErr (hang herald 2 (pprFamInsts sorted))
+ = setSrcSpan srcSpan $
+ addErr (hang herald 2 $ vcat (zipWith pprFamInstBranchHdr
+ sortedAxioms sortedBranches))
where
- sorted = sortWith getSrcLoc insts
+ getSpan = famInstBranchSpan . snd
+ sorted = sortWith getSpan insts
+ srcSpan = getSpan $ head sorted
+
+ sortedAxioms = map (famInstAxiom . fst) sorted
+ sortedBranches = map snd sorted
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index f0394c8762240dc917eb1d623f5261c4048db58d..a15aaab3f67f4a244116e6ff649fa970cc69d824 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -241,7 +241,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
-- co : t -> IP "x" t
toDict ipClass x ty =
case unwrapNewTyCon_maybe (classTyCon ipClass) of
- Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcAxInstCo ax [x,ty]
+ Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo ax [x,ty]
Nothing -> panic "The dictionary for `IP` is not a newtype?"
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 7df818efd233d61a60985cb5c2b8abb46f23052f..0579fcb8653798c63de2df3ecd882e337fc7cb7e 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -16,7 +16,7 @@ Typechecking class declarations
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
- tcAddDeclCtxt, badMethodErr
+ tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
) where
#include "HsVersions.h"
@@ -349,12 +349,13 @@ This makes the error messages right.
%************************************************************************
\begin{code}
+tcMkDeclCtxt :: TyClDecl Name -> SDoc
+tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
+ ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
+
tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
- = addErrCtxt ctxt thing_inside
- where
- ctxt = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
- ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
+ = addErrCtxt (tcMkDeclCtxt decl) thing_inside
badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr clas op
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 916c77779e1d54e00c68200d2509b3e0d13b998d..68f327e27a4746f821ee19eece1955fc1d8744ff 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -16,7 +16,7 @@ import DynFlags
import TcRnMonad
import FamInst
import TcEnv
-import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt )
+import TcTyClsDecls( tcFamTyPats, tcAddDataFamInstCtxt )
import TcClassDcl( tcAddDeclCtxt ) -- Small helper
import TcGenDeriv -- Deriv stuff
import TcGenGenerics
@@ -43,6 +43,7 @@ import RdrName
import Name
import NameSet
import TyCon
+import CoAxiom
import TcType
import Var
import VarSet
@@ -348,8 +349,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
where
ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
- -> Bag TyCon -- ^ Empty data constructors
- -> Bag FamInst -- ^ Rep type family instances
+ -> Bag TyCon -- ^ Empty data constructors
+ -> Bag (FamInst Unbranched) -- ^ Rep type family instances
-> SDoc
ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
= hang (ptext (sLit "Derived instances:"))
@@ -363,6 +364,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+-- Prints the representable type family instance
+pprRepTy :: FamInst Unbranched -> SDoc
+pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
+ , fib_rhs = rhs }) })
+ = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
+ equals <+> ppr rhs
-- As of 24 April 2012, this only shares MetaTyCons between derivations of
@@ -380,13 +387,6 @@ commonAuxiliaries = foldM snoc ([], emptyBag) where
| otherwise = do (ca, new_stuff) <- m
return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
-
-
--- Prints the representable type family instance
-pprRepTy :: FamInst -> SDoc
-pprRepTy fi
- = pprFamInstHdr fi <+> ptext (sLit "=") <+> ppr (coAxiomRHS (famInstAxiom fi))
-
renameDeriv :: Bool
-> [InstInfo RdrName]
-> Bag (LHsBind RdrName, LSig RdrName)
@@ -487,8 +487,8 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
-deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name
- , tcdTyDefn = TyData { td_derivs = Just preds } }))
+deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
+ , tcdDataDefn = HsDataDefn { dd_derivs = Just preds } }))
= tcAddDeclCtxt decl $
do { tc <- tcLookupTyCon tc_name
; let tvs = tyConTyVars tc
@@ -499,16 +499,17 @@ deriveTyDecl _ = return []
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
-deriveInstDecl (L _ (FamInstD { lid_inst = fam_inst }))
+deriveInstDecl (L _ (TyFamInstD {})) = return []
+deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
= deriveFamInst fam_inst
-deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
+deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_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 $
+deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
+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 }
@@ -1527,10 +1528,10 @@ genInst standalone_deriv oflag comauxs
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
- Just co_con -> mkTcAxInstCo co_con rep_tc_args
+ Just co_con -> mkTcUnbranchedAxInstCo co_con rep_tc_args
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
- co2 = mkTcAxInstCo (newTyConCo rep_tycon) rep_tc_args
+ co2 = mkTcUnbranchedAxInstCo (newTyConCo rep_tycon) rep_tc_args
co = mkTcForAllCos tvs (co1 `mkTcTransCo` co2)
id_co = mkTcReflCo (mkTyConApp rep_tycon rep_tc_args)
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 934a9fb84af49a4e7a4c4919ad2e229064381a6d..3a5cda38864ce2689a6a5cf1780ce4ab0c5cce3a 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -72,6 +72,7 @@ import RdrName
import InstEnv
import DataCon
import TyCon
+import CoAxiom
import TypeRep
import Class
import Name
@@ -87,7 +88,6 @@ import Encoding
import FastString
import ListSetOps
import Util
-
import Data.IORef
import Data.List
\end{code}
@@ -173,7 +173,7 @@ tcLookupTyCon name = do
ATyCon tc -> return tc
_ -> wrongThingErr "type constructor" (AGlobal thing) name
-tcLookupAxiom :: Name -> TcM CoAxiom
+tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom name = do
thing <- tcLookupGlobal name
case thing of
@@ -731,17 +731,21 @@ Make a name for the representation tycon of a family instance. It's an
newGlobalBinder.
\begin{code}
-newFamInstTyConName, newFamInstAxiomName :: Located Name -> [Type] -> TcM Name
-newFamInstTyConName = mk_fam_inst_name id
+newFamInstTyConName :: Located Name -> [Type] -> TcM Name
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
+
+newFamInstAxiomName :: SrcSpan -> Name -> [[Type]] -> TcM Name
newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc
-mk_fam_inst_name :: (OccName -> OccName) -> Located Name -> [Type] -> TcM Name
-mk_fam_inst_name adaptOcc (L loc tc_name) tys
+mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
+mk_fam_inst_name adaptOcc loc tc_name tyss
= do { mod <- getModule
; let info_string = occNameString (getOccName tc_name) ++
- concatMap (occNameString.getDFunTyKey) tys
+ intercalate "|" ty_strings
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
; newGlobalBinder mod (adaptOcc occ) loc }
+ where
+ ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
\end{code}
Stable names used for foreign exports and annotations.
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index b160c3282c831735ec500a9f92b64a398524caa0..fe38a073130f884e28c91df76d23fe24766a3b71 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -22,7 +22,7 @@ module TcEvidence (
-- TcCoercion
TcCoercion(..), LeftOrRight(..), pickLR,
mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo,
- mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos,
+ mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,
mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcInstCos,
tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo,
isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe,
@@ -36,9 +36,10 @@ import Coercion( LeftOrRight(..), pickLR )
import PprCore () -- Instance OutputableBndr TyVar
import TypeRep -- Knows type representation
import TcType
-import Type( tyConAppArgN, tyConAppTyCon_maybe, getEqPredTys )
+import Type( tyConAppArgN, tyConAppTyCon_maybe, getEqPredTys, coAxNthLHS )
import TysPrim( funTyCon )
import TyCon
+import CoAxiom
import PrelNames
import VarEnv
import VarSet
@@ -98,7 +99,8 @@ data TcCoercion
| TcForAllCo TyVar TcCoercion
| TcInstCo TcCoercion TcType
| TcCoVarCo EqVar
- | TcAxiomInstCo CoAxiom [TcType]
+ | TcAxiomInstCo (CoAxiom Branched) Int [TcType] -- Int specifies branch number
+ -- See [CoAxiom Index] in Coercion.lhs
| TcSymCo TcCoercion
| TcTransCo TcCoercion TcCoercion
| TcNthCo Int TcCoercion
@@ -139,15 +141,20 @@ mkTcTyConAppCo tc cos -- No need to expand type synonyms
| otherwise = TcTyConAppCo tc cos
-mkTcAxInstCo :: CoAxiom -> [TcType] -> TcCoercion
-mkTcAxInstCo ax tys
- | arity == n_tys = TcAxiomInstCo ax tys
+mkTcAxInstCo :: CoAxiom br -> Int -> [TcType] -> TcCoercion
+mkTcAxInstCo ax ind tys
+ | arity == n_tys = TcAxiomInstCo ax_br ind tys
| otherwise = ASSERT( arity < n_tys )
- foldl TcAppCo (TcAxiomInstCo ax (take arity tys))
+ foldl TcAppCo (TcAxiomInstCo ax_br ind (take arity tys))
(map TcRefl (drop arity tys))
where
n_tys = length tys
- arity = coAxiomArity ax
+ arity = coAxiomArity ax ind
+ ax_br = toBranchedAxiom ax
+
+mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] -> TcCoercion
+mkTcUnbranchedAxInstCo ax tys
+ = mkTcAxInstCo ax 0 tys
mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion
-- No need to deal with TyConApp on the left; see Note [TcCoercions]
@@ -211,8 +218,11 @@ tcCoercionKind co = go co
go (TcForAllCo tv co) = mkForAllTy tv <$> go co
go (TcInstCo co ty) = go_inst co [ty]
go (TcCoVarCo cv) = eqVarKind cv
- go (TcAxiomInstCo ax tys) = Pair (substTyWith (co_ax_tvs ax) tys (co_ax_lhs ax))
- (substTyWith (co_ax_tvs ax) tys (co_ax_rhs ax))
+ go (TcAxiomInstCo ax ind tys)
+ = let branch = coAxiomNthBranch ax ind
+ tvs = coAxBranchTyVars branch
+ in Pair (substTyWith tvs tys (coAxNthLHS ax ind))
+ (substTyWith tvs tys (coAxBranchRHS branch))
go (TcSymCo co) = swap (go co)
go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2))
go (TcNthCo d co) = tyConAppArgN d <$> go co
@@ -305,7 +315,9 @@ ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $
pprParendTcCo co <> ptext (sLit "@") <> pprType ty
ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
-ppr_co p (TcAxiomInstCo con cos) = pprTypeNameApp p ppr_type (getName con) cos
+
+ppr_co p (TcAxiomInstCo con ind cos)
+ = pprPrefixApp p (ppr (getName con) <> brackets (ppr ind)) (map (ppr_type TyConPrec) cos)
ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $
ppr_co FunPrec co1
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index d554588e00e55b8f2a7bacd1901d7e547d38948e..e87ff6d2f4d5bf02fead7493fb39c772901f2c0c 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -32,7 +32,7 @@ import BasicTypes
import Inst
import TcBinds
import FamInst ( tcLookupFamInst )
-import FamInstEnv ( famInstAxiom, dataFamInstRepTyCon )
+import FamInstEnv ( famInstAxiom, dataFamInstRepTyCon, FamInstMatch(..) )
import TcEnv
import TcArrows
import TcMatches
@@ -194,7 +194,7 @@ tcExpr (HsIPVar x) res_ty
-- Coerces a dictionry for `IP "x" t` into `t`.
fromDict ipClass x ty =
case unwrapNewTyCon_maybe (classTyCon ipClass) of
- Just (_,_,ax) -> HsWrap $ WpCast $ mkTcAxInstCo ax [x,ty]
+ Just (_,_,ax) -> HsWrap $ WpCast $ mkTcUnbranchedAxInstCo ax [x,ty]
Nothing -> panic "The dictionary for `IP` is not a newtype?"
tcExpr (HsLam match) res_ty
@@ -714,7 +714,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
- = WpCast (mkTcAxInstCo co_con scrut_inst_tys)
+ = WpCast (mkTcUnbranchedAxInstCo co_con scrut_inst_tys)
| otherwise
= idHsWrapper
-- Phew!
@@ -1209,8 +1209,10 @@ tcTagToEnum loc fun_name arg res_ty
= do { mb_fam <- tcLookupFamInst tc tc_args
; case mb_fam of
Nothing -> failWithTc (tagToEnumError ty doc3)
- Just (rep_fam, rep_args)
- -> return ( mkTcSymCo (mkTcAxInstCo co_tc rep_args)
+ Just (FamInstMatch { fim_instance = rep_fam
+ , fim_index = index
+ , fim_tys = rep_args })
+ -> return ( mkTcSymCo (mkTcAxInstCo co_tc index rep_args)
, rep_tc, rep_args )
where
co_tc = famInstAxiom rep_fam
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index c691bd0ad3b7681766d6c03458f3fcbe4bd81938..4ac5f48dd6e9a86711870e940327dcc6069b53bf 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -90,7 +90,7 @@ normaliseFfiType' env ty0 = go [] ty0
= do { rdr_env <- getGlobalRdrEnv
; case checkNewtypeFFI rdr_env rec_nts tc of
Nothing -> children_only
- Just gre -> do { let nt_co = mkAxInstCo (newTyConCo tc) tys
+ Just gre -> do { let nt_co = mkUnbranchedAxInstCo (newTyConCo tc) tys
; (co', ty', gres) <- go rec_nts' nt_rhs
; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 2ae812e8c359b626036d494a488b686ac0f5bcbe..950715bb7740638630dadff1c44bb6b9e8403860 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -51,6 +51,7 @@ import PrelNames hiding (error_RDR)
import PrimOp
import SrcLoc
import TyCon
+import CoAxiom
import TcType
import TysPrim
import TysWiredIn
@@ -85,8 +86,8 @@ data DerivStuff -- Please add this auxiliary stuff
= DerivAuxBind AuxBindSpec
-- Generics
- | DerivTyCon TyCon -- New data types
- | DerivFamInst FamInst -- New type family instances
+ | DerivTyCon TyCon -- New data types
+ | DerivFamInst (FamInst Unbranched) -- New type family instances
-- New top-level auxiliary bindings
| DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
@@ -1801,7 +1802,7 @@ type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
( Bag (LHsBind RdrName, LSig RdrName)
-- Extra bindings (used by Generic only)
, Bag TyCon -- Extra top-level datatypes
- , Bag FamInst -- Extra family instances
+ , Bag (FamInst Unbranched) -- Extra family instances
, Bag (InstInfo RdrName)) -- Extra instances
genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 0109a99e3c8006cfbc027b18af274a3846d17550..3941017789ea32b419777af9e8356675f77dd79d 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -27,7 +27,8 @@ import TcType
import TcGenDeriv
import DataCon
import TyCon
-import FamInstEnv ( FamInst, mkSynFamInst )
+import CoAxiom
+import FamInstEnv ( FamInst, mkSingleSynFamInst )
import Module ( Module, moduleName, moduleNameString )
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
@@ -70,7 +71,7 @@ For the generic representation we need to generate:
\begin{code}
gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
- -> TcM (LHsBinds RdrName, FamInst)
+ -> TcM (LHsBinds RdrName, FamInst Unbranched)
gen_Generic_binds gk tc metaTyCons mod = do
repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
return (mkBindsRep gk tc, repTyInsts)
@@ -405,11 +406,11 @@ mkBindsRep gk tycon =
-- type Rep_D a b = ...representation type for D ...
--------------------------------------------------------------------------------
-tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
+tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
-> TyCon -- The type to generate representation for
-> MetaTyCons -- Metadata datatypes to refer to
-> Module -- Used as the location of the new RepTy
- -> TcM FamInst -- Generated representation0 coercion
+ -> TcM (FamInst Unbranched) -- Generated representation0 coercion
tc_mkRepFamInsts gk tycon metaDts mod =
-- Consider the example input tycon `D`, where data D a b = D_ a
-- Also consider `R:DInt`, where { data family D x y :: * -> *
@@ -448,7 +449,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
(nameSrcSpan (tyConName tycon))
- ; return $ mkSynFamInst rep_name tyvars rep appT repTy
+ ; return $ mkSingleSynFamInst rep_name tyvars rep appT repTy
}
--------------------------------------------------------------------------------
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 92d2a5c96ede32f0d28e151919a4e5fd04e626f9..cdcb040e85803df6cdfe7c78f49424ab19119b5a 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -1390,7 +1390,8 @@ zonkTcLCoToLCo env co
go (TcRefl ty) = do { ty' <- zonkTcTypeToType env ty
; return (TcRefl ty') }
go (TcTyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTcTyConAppCo tc cos') }
- go (TcAxiomInstCo ax tys) = do { tys' <- zonkTcTypeToTypes env tys; return (TcAxiomInstCo ax tys') }
+ go (TcAxiomInstCo ax ind tys)
+ = do { tys' <- zonkTcTypeToTypes env tys; return (TcAxiomInstCo ax ind tys') }
go (TcAppCo co1 co2) = do { co1' <- go co1; co2' <- go co2
; return (mkTcAppCo co1' co2') }
go (TcCastCo co1 co2) = do { co1' <- go co1; co2' <- go co2
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 7226a5cf50b1d2ad954c019a8dea2d22bab3106d..bd6798bad24b61cbeff0f1f942d6a9a41c750494 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -19,8 +19,9 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
-import TcTyClsDecls( tcAddImplicits, tcAddFamInstCtxt, tcSynFamInstDecl,
- wrongKindOfFamily, tcFamTyPats, kcTyDefn, dataDeclChecks,
+import TcTyClsDecls( tcAddImplicits, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
+ tcAddFamInstCtxt, tcSynFamInstDecl,
+ wrongKindOfFamily, tcFamTyPats, kcDataDefn, dataDeclChecks,
tcConDecls, checkValidTyCon, badATErr, wrongATArgErr )
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs,
@@ -43,6 +44,7 @@ import CoreSyn ( DFunArg(..) )
import Type
import TcEvidence
import TyCon
+import CoAxiom
import DataCon
import Class
import Var
@@ -427,12 +429,12 @@ addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
-addFamInsts :: [FamInst] -> TcM a -> TcM a
+addFamInsts :: [FamInst Branched] -> TcM a -> TcM a
-- Extend (a) the family instance envt
-- (b) the type envt with stuff from data type decls
addFamInsts fam_insts thing_inside
= tcExtendLocalFamInstEnv fam_insts $
- tcExtendGlobalEnv things $
+ tcExtendGlobalEnv things $
do { traceTc "addFamInsts" (pprFamInsts fam_insts)
; tcg_env <- tcAddImplicits things
; setGblEnv tcg_env thing_inside }
@@ -461,21 +463,35 @@ the brutal solution will do.
\begin{code}
tcLocalInstDecl :: LInstDecl Name
- -> TcM ([InstInfo Name], [FamInst])
+ -> TcM ([InstInfo Name], [FamInst Branched])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
-tcLocalInstDecl (L loc (FamInstD { lid_inst = decl }))
+tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
= setSrcSpan loc $
- tcAddFamInstCtxt decl $
- do { fam_inst <- tcFamInstDecl TopLevel decl
+ tcAddTyFamInstCtxt decl $
+ do { fam_tc <- tcFamInstDeclCombined TopLevel (tyFamInstDeclLName decl)
+ ; fam_inst <- tcTyFamInstDecl fam_tc (L loc decl)
; return ([], [fam_inst]) }
-tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
- , cid_sigs = uprags, cid_fam_insts = ats }))
- = setSrcSpan loc $
- addErrCtxt (instDeclCtxt1 poly_ty) $
+tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
+ = setSrcSpan loc $
+ tcAddDataFamInstCtxt decl $
+ do { fam_tc <- tcFamInstDeclCombined TopLevel (dfid_tycon decl)
+ ; fam_inst <- tcDataFamInstDecl fam_tc decl
+ ; return ([], [toBranchedFamInst fam_inst]) }
+
+tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
+ = setSrcSpan loc $
+ do { (insts, fam_insts) <- tcClsInstDecl decl
+ ; return (insts, map toBranchedFamInst fam_insts) }
+
+tcClsInstDecl :: ClsInstDecl Name -> TcM ([InstInfo Name], [FamInst Unbranched])
+tcClsInstDecl (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
+ , cid_sigs = uprags, cid_tyfam_insts = ats
+ , cid_datafam_insts = adts })
+ = addErrCtxt (instDeclCtxt1 poly_ty) $
do { is_boot <- tcIsHsBoot
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
@@ -487,17 +503,24 @@ tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
-- Next, process any associated types.
; traceTc "tcLocalInstDecl" (ppr poly_ty)
- ; fam_insts0 <- tcExtendTyVarEnv tyvars $
- mapAndRecoverM (tcAssocDecl clas mini_env) ats
+ ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
+ mapAndRecoverM tcAssocTyDecl ats
+ ; datafam_insts <- tcExtendTyVarEnv tyvars $
+ mapAndRecoverM tcAssocDataDecl adts
+
+ -- discard the [()]
+ ; _ <- mapAndRecoverM (tcAssocFamInst clas mini_env) (tyfam_insts0 ++ datafam_insts)
-- Check for missing associated types and build them
-- from their defaults (if available)
- ; let defined_ats = mkNameSet $ map famInstDeclName ats
+ ; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats
+ defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts
- mk_deflt_at_instances :: ClassATItem -> TcM [FamInst]
+ mk_deflt_at_instances :: ClassATItem -> TcM [FamInst Unbranched]
mk_deflt_at_instances (fam_tc, defs)
-- User supplied instances ==> everything is OK
- | tyConName fam_tc `elemNameSet` defined_ats
+ | tyConName fam_tc `elemNameSet` defined_ats
+ || tyConName fam_tc `elemNameSet` defined_adts
= return []
-- No defaults ==> generate a warning
@@ -517,9 +540,9 @@ tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
tvs' = varSetElems tv_set'
; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
- return (mkSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') }
+ return (mkSingleSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') }
- ; fam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
+ ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
@@ -531,7 +554,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
ispec = mkLocalInstance dfun overlap_flag
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }
- ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) }
+ ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
\end{code}
%************************************************************************
@@ -546,12 +569,11 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
-tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst
-tcFamInstDecl top_lvl decl
+tcFamInstDeclCombined :: TopLevelFlag -> Located Name -> TcM TyCon
+tcFamInstDeclCombined top_lvl fam_tc_lname
= do { -- Type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
- ; traceTc "tcFamInstDecl" (ppr decl)
- ; let fam_tc_lname = fid_tycon decl
+ ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl fam_tc_lname
@@ -563,44 +585,68 @@ tcFamInstDecl top_lvl decl
; when (isTopLevel top_lvl && isTyConAssoc fam_tc)
(addErr $ assocInClassErr fam_tc_lname)
- -- Now check the type/data instance itself
- -- This is where type and data decls are treated separately
- ; tcFamInstDecl1 fam_tc decl }
-
-tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst
+ ; return fam_tc }
+tcTyFamInstDecl :: TyCon -> LTyFamInstDecl Name -> TcM (FamInst Branched)
-- "type instance"
-tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name
- , fid_defn = TySynonym {} })
+tcTyFamInstDecl fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
= do { -- (0) Check it's an open type family
checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
; checkTc (isOpenSynFamilyTyCon fam_tc)
(notOpenFamily fam_tc)
- -- (1) do the work of verifying the synonym
- ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl
+ -- (1) do the work of verifying the synonym group
+ ; quads <- tcSynFamInstDecl fam_tc decl
+
+ -- (2) create the branches
+ ; fam_inst_branches <- mapM check_valid_mk_branch quads
+
+ -- (3) construct coercion tycon
+ ; rep_tc_name <- newFamInstAxiomName loc
+ (tyFamInstDeclName decl)
+ (get_typats quads)
+
+ -- (4) check to see if earlier equations dominate a later one
+ ; foldlM_ check_inaccessible_branches [] (map fst fam_inst_branches)
- -- (2) check the well-formedness of the instance
- ; checkValidFamInst t_typats t_rhs
+ -- now, build the FamInstGroup
+ ; return $ mkSynFamInst rep_tc_name fam_tc group fam_inst_branches }
- -- (3) construct representation tycon
- ; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats
+ where check_valid_mk_branch :: ([TyVar], [Type], Type, SrcSpan)
+ -> TcM (FamInstBranch, CoAxBranch)
+ check_valid_mk_branch (t_tvs, t_typats, t_rhs, loc)
+ = setSrcSpan loc $
+ do { -- check the well-formedness of the instance
+ checkValidFamInst t_typats t_rhs
- ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
+ ; return $ mkSynFamInstBranch loc t_tvs t_typats t_rhs }
+ check_inaccessible_branches :: [FamInstBranch] -- previous
+ -> FamInstBranch -- current
+ -> TcM [FamInstBranch] -- current : previous
+ check_inaccessible_branches prev_branches
+ cur_branch@(FamInstBranch { fib_lhs = tys })
+ = setSrcSpan (famInstBranchSpan cur_branch) $
+ do { when (tys `isDominatedBy` prev_branches) $
+ addErrTc $ inaccessibleFamInstBranch fam_tc cur_branch
+ ; return $ cur_branch : prev_branches }
+
+ get_typats = map (\(_, tys, _, _) -> tys)
+
+tcDataFamInstDecl :: TyCon -> DataFamInstDecl Name -> TcM (FamInst Unbranched)
-- "newtype instance" and "data instance"
-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 } })
+tcDataFamInstDecl fam_tc
+ (DataFamInstDecl { dfid_pats = pats
+ , dfid_tycon = fam_tc_name
+ , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = ctxt, dd_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 pats (kcTyDefn defn) $
+ ; tcFamTyPats fam_tc pats (kcDataDefn defn) $
\tvs' pats' res_kind -> do
-- Check that left-hand side contains no type family applications
@@ -643,24 +689,23 @@ tcFamInstDecl1 fam_tc
----------------
-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 $
- tcAddFamInstCtxt decl $
- do { fam_inst <- tcFamInstDecl NotTopLevel decl
- ; let (fam_tc, at_tys) = famInstLHS fam_inst
+tcAssocFamInst :: Class -- ^ Class of associated type
+ -> VarEnv Type -- ^ Instantiation of class TyVars
+ -> FamInst Unbranched -- ^ RHS
+ -> TcM ()
+tcAssocFamInst clas mini_env fam_inst
+ = setSrcSpan (getSrcSpan fam_inst) $
+ tcAddFamInstCtxt (pprFamFlavor (fi_flavor fam_inst)) (fi_fam fam_inst) $
+ do { let branch = famInstSingleBranch fam_inst
+ fam_tc = famInstTyCon fam_inst
+ at_tys = famInstBranchLHS branch
-- Check that the associated type comes from this class
; checkTc (Just clas == tyConAssoc_maybe fam_tc)
(badATErr (className clas) (tyConName fam_tc))
-- See Note [Checking consistent instantiation] in TcTyClsDecls
- ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
-
- ; return fam_inst }
+ ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys }
where
check_arg fam_tc_tv at_ty
| Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
@@ -671,6 +716,23 @@ tcAssocDecl clas mini_env (L loc decl)
| otherwise
= return () -- Allow non-type-variable instantiation
-- See Note [Associated type instances]
+
+tcAssocTyDecl :: LTyFamInstDecl Name
+ -> TcM (FamInst Unbranched)
+tcAssocTyDecl ldecl@(L loc decl)
+ = setSrcSpan loc $
+ tcAddTyFamInstCtxt decl $
+ do { fam_tc <- tcFamInstDeclCombined NotTopLevel (tyFamInstDeclLName decl)
+ ; fam_inst <- tcTyFamInstDecl fam_tc ldecl
+ ; return $ toUnbranchedFamInst fam_inst }
+
+tcAssocDataDecl :: LDataFamInstDecl Name -- ^ RHS
+ -> TcM (FamInst Unbranched)
+tcAssocDataDecl (L loc decl)
+ = setSrcSpan loc $
+ tcAddDataFamInstCtxt decl $
+ do { fam_tc <- tcFamInstDeclCombined NotTopLevel (dfid_tycon decl)
+ ; tcDataFamInstDecl fam_tc decl }
\end{code}
@@ -1450,6 +1512,11 @@ badFamInstDecl tc_name
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
+inaccessibleFamInstBranch :: TyCon -> FamInstBranch -> SDoc
+inaccessibleFamInstBranch tc fi
+ = ptext (sLit "Inaccessible family instance equation:") $$
+ (pprFamInstBranch 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 3facc1e7e4b6049b98933541ac81bdb7313052ee..2198996a9c56473f8d55721e920b547002b7cef2 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1480,15 +1480,17 @@ doTopReactFunEq _ct fl fun_tc args xi loc
do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of {
Nothing -> return NoTopInt ;
- Just (famInst, rep_tys) ->
+ Just (FamInstMatch { fim_instance = famInst
+ , fim_index = index
+ , fim_tys = rep_tys }) ->
-- Found a top-level instance
do { -- Add it to the solved goals
unless (isDerived fl) (addSolvedFunEq fam_ty fl xi)
; let coe_ax = famInstAxiom famInst
- ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax rep_tys)
- (mkAxInstRHS coe_ax rep_tys) } } } } }
+ ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax index rep_tys)
+ (mkAxInstRHS coe_ax index rep_tys) } } } } }
where
fam_ty = mkTyConApp fun_tc args
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 5bc6e9b5ecb604fa82c1fde8ed4a414aa0ba8e28..548a11d236d2afbf398a64241359b75d611148c9 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -753,7 +753,7 @@ matchExpectedConTy data_tc pat_ty
; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
-- co1 : T (ty1,ty2) ~ pat_ty
- ; let co2 = mkTcAxInstCo co_tc tys
+ ; let co2 = mkTcUnbranchedAxInstCo co_tc tys
-- co2 : T (ty1,ty2) ~ T7 ty1 ty2
; return (mkTcSymCo co2 `mkTcTransCo` co1, tys) }
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 22faed695b3f47a43a8d27ff9b9c866f217c8eb5..c907a96fb88cf7ab68c0f4ef73711dd7d91405b7 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -488,6 +488,8 @@ tc_rn_src_decls boot_details ds
setEnvs (tcg_env, tcl_env) $
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
return (tcg_env, tcl_env)
} ;
@@ -955,7 +957,7 @@ 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
@@ -992,13 +994,14 @@ tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
where
-- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl Name -> [Name]
- get_cons (L _ (FamInstD { lid_inst = fid })) = get_fi_cons fid
- get_cons (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_cons . unLoc) fids
+ get_cons (L _ (TyFamInstD {})) = []
+ get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
+ get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
+ = concatMap (get_fi_cons . unLoc) fids
- get_fi_cons :: FamInstDecl Name -> [Name]
- get_fi_cons (FamInstDecl { fid_defn = TyData { td_cons = cons } })
+ get_fi_cons :: DataFamInstDecl Name -> [Name]
+ get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
= map (unLoc . con_name . unLoc) cons
- get_fi_cons (FamInstDecl {}) = []
\end{code}
Note [AFamDataCon: not promoting data family constructors]
@@ -1634,6 +1637,8 @@ tcRnDeclsi hsc_env ictxt local_decls =
tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env
+ traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE
+
return tcg_env''
@@ -1865,7 +1870,7 @@ ppr_types insts type_env
-- that the type checker has invented. Top-level user-defined things
-- have External names.
-ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons :: [FamInst br] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env
= vcat [ text "TYPE CONSTRUCTORS"
, nest 2 (ppr_tydecls tycons)
@@ -1883,7 +1888,7 @@ ppr_insts :: [ClsInst] -> SDoc
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
-ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts :: [FamInst br] -> SDoc
ppr_fam_insts [] = empty
ppr_fam_insts fam_insts =
text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 8388b252269449cc79a0c3632b666db201127be2..5a555657b53274da4c5f72e0f79a6b72e13c5c58 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -298,7 +298,7 @@ data TcGblEnv
tcg_anns :: [Annotation], -- ...Annotations
tcg_tcs :: [TyCon], -- ...TyCons and Classes
tcg_insts :: [ClsInst], -- ...Instances
- tcg_fam_insts :: [FamInst], -- ...Family instances
+ tcg_fam_insts :: [FamInst Branched],-- ...Family instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 7541cd79f9c30573383ad451d21d6b3cd3efeb15..282b2b58f8ceb302b5f58286582c87ec2a44bed8 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1678,7 +1678,7 @@ matchClass clas tys
}
}
-matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type]))
+matchFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args
\end{code}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index d5acf6ca28c1be6425986b90416f4ddc055df43d..22d8c08e90682ade161ca16c59faf6cd8eefc733 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -56,6 +56,7 @@ import TcRnMonad
import Class
import Inst
import TyCon
+import CoAxiom
import DataCon
import TcEvidence( TcEvBinds(..) )
import Id
@@ -69,7 +70,6 @@ import SrcLoc
import Outputable
import Util
import Data.List ( mapAccumL )
-import Pair
import Unique
import Data.Maybe
import BasicTypes
@@ -1022,7 +1022,7 @@ reifyInstances th_nm th_tys
-> do { tys <- tc_types tc th_tys
; inst_envs <- tcGetFamInstEnvs
; let matches = lookupFamInstEnv inst_envs tc tys
- ; mapM (reifyFamilyInstance . fst) matches }
+ ; mapM (reifyFamilyInstance . fim_instance) matches }
_ -> bale_out (ppr_th th_nm <+> ptext (sLit "is not a class or type constructor"))
}
where
@@ -1198,15 +1198,16 @@ reifyThing (ATyVar tv tv1)
reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
------------------------------
-reifyAxiom :: CoAxiom -> TcM TH.Info
-reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
- | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+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
; rhs' <- reifyType rhs
- ; return (TH.TyConI (TH.TySynInstD (reifyName tc) args' rhs') )}
- | otherwise
- = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
- <+> dcolon <+> pprEqPred (Pair lhs rhs))
+ ; return (TH.TySynEqn args' rhs') }
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
@@ -1311,25 +1312,30 @@ reifyClassInstance i
n_silent = dfunNSilent (instanceDFunId i)
------------------------------
-reifyFamilyInstance :: FamInst -> TcM TH.Dec
-reifyFamilyInstance fi
- = case fi_flavor fi of
+reifyFamilyInstance :: FamInst br -> TcM TH.Dec
+reifyFamilyInstance fi@(FamInst { fi_flavor = flavor
+ , fi_branches = branches
+ , fi_fam = fam })
+ = case flavor of
SynFamilyInst ->
- do { th_tys <- reifyTypes (fi_tys fi)
- ; rhs_ty <- reifyType (coAxiomRHS rep_ax)
- ; return (TH.TySynInstD fam th_tys rhs_ty) }
+ do { th_eqns <- sequence $ brListMap reifyFamInstBranch branches
+ ; return (TH.TySynInstD (reifyName fam) th_eqns) }
DataFamilyInst rep_tc ->
do { let tvs = tyConTyVars rep_tc
- fam = reifyName (fi_fam fi)
+ fam' = reifyName fam
+ lhs = famInstBranchLHS $ famInstSingleBranch (toUnbranchedFamInst fi)
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
- ; th_tys <- reifyTypes (fi_tys fi)
+ ; th_tys <- reifyTypes lhs
; return (if isNewTyCon rep_tc
- then TH.NewtypeInstD [] fam th_tys (head cons) []
- else TH.DataInstD [] fam th_tys cons []) }
- where
- rep_ax = fi_axiom fi
- fam = reifyName (fi_fam fi)
+ then TH.NewtypeInstD [] fam' th_tys (head cons) []
+ else TH.DataInstD [] fam' th_tys cons []) }
+
+reifyFamInstBranch :: FamInstBranch -> TcM TH.TySynEqn
+reifyFamInstBranch (FamInstBranch { fib_lhs = lhs, fib_rhs = rhs })
+ = do { th_lhs <- reifyTypes lhs
+ ; th_rhs <- reifyType rhs
+ ; return (TH.TySynEqn th_lhs th_rhs) }
------------------------------
reifyType :: TypeRep.Type -> TcM TH.Type
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 46a944590a23e977bb60200f7754eb248884bb75..22079d62191e63c31e126deb458f4ef3cc7f32e5 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -12,15 +12,17 @@ TcTyClsDecls: Typecheck type and class declarations
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
+{-# LANGUAGE TupleSections #-}
module TcTyClsDecls (
tcTyAndClassDecls, tcAddImplicits,
-- Functions used by TcInstDcls to check
-- data/type family instance declarations
- kcTyDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
+ kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcSynFamInstDecl, tcFamTyPats,
- tcAddFamInstCtxt, wrongKindOfFamily, badATErr, wrongATArgErr
+ tcAddFamInstCtxt, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
+ wrongKindOfFamily, badATErr, wrongATArgErr
) where
#include "HsVersions.h"
@@ -148,8 +150,7 @@ tcTyClGroup boot_details tyclds
; tcExtendGlobalEnv tyclss $ do
{ traceTc "Starting validity check" (ppr tyclss)
; checkNoErrs $
- mapM_ (recoverM (return ()) . addLocM checkValidTyCl)
- (flattenTyClDecls tyclds)
+ mapM_ (recoverM (return ()) . addLocM checkValidTyCl) tyclds
-- We recover, which allows us to report multiple validity errors
-- but we then fail if any are wrong. Lacking the checkNoErrs
-- we get Trac #7175
@@ -162,7 +163,7 @@ tcTyClGroup boot_details tyclds
tcAddImplicits :: [TyThing] -> TcM TcGblEnv
tcAddImplicits tyclss
- = tcExtendGlobalEnvImplicit implicit_things $
+ = tcExtendGlobalEnvImplicit implicit_things $
tcRecSelBinds rec_sel_binds
where
implicit_things = concatMap implicitTyThings tyclss
@@ -184,13 +185,6 @@ zipRecTyClss kind_pairs rec_things
get name = case lookupTypeEnv rec_type_env name of
Just (ATyCon tc) -> tc
other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
-
-flattenTyClDecls :: [LTyClDecl Name] -> [LTyClDecl Name]
--- Lift out the associated type declaraitons to top level
-flattenTyClDecls [] = []
-flattenTyClDecls (ld@(L _ d) : lds)
- | isClassDecl d = ld : tcdATs d ++ flattenTyClDecls lds
- | otherwise = ld : flattenTyClDecls lds
\end{code}
@@ -286,18 +280,16 @@ kcTyClGroup decls
-- Step 4: generalisation
-- Kind checking done for this group
-- Now we have to kind generalize the flexis
- ; res <- mapM (generalise (tcl_env lcl_env)) (flattenTyClDecls decls)
+ ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
; traceTc "kcTyClGroup result" (ppr res)
; return res }
where
- generalise :: TcTypeEnv -> LTyClDecl Name -> TcM (Name, Kind)
+ generalise :: TcTypeEnv -> Name -> LHsTyVarBndrs Name -> TcM (Name, Kind)
-- For polymorphic things this is a no-op
- generalise kind_env (L _ decl)
- = do { let name = tcdName decl
- tvs = tcdTyVars decl
- ; let kc_kind = case lookupNameEnv kind_env name of
+ generalise kind_env name tvs
+ = do { let kc_kind = case lookupNameEnv kind_env name of
Just (AThing k) -> k
_ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
; kvs <- kindGeneralize (tyVarsOfType kc_kind) (hsLTyVarNames tvs)
@@ -306,14 +298,45 @@ kcTyClGroup decls
; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ])
; return (name, mkForAllTys kvs kc_kind') }
+ generaliseTCD :: TcTypeEnv -> LTyClDecl Name -> TcM [(Name, Kind)]
+ generaliseTCD kind_env (L _ decl)
+ | ClassDecl { tcdLName = (L _ name), tcdTyVars = tyvars, tcdATs = ats } <- decl
+ = do { first <- generalise kind_env name tyvars
+ ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats
+ ; return (first : rest) }
+
+ | FamDecl { tcdFam = fam } <- decl
+ = do { res <- generaliseFamDecl kind_env fam
+ ; return [res] }
+
+ | ForeignType {} <- decl
+ = pprPanic "generaliseTCD" (ppr decl)
+
+ | otherwise
+ -- Note: tcdTyVars is safe here because we've eliminated FamDecl and ForeignType
+ = do { res <- generalise kind_env (tcdName decl) (tcdTyVars decl)
+ ; return [res] }
+
+ generaliseFamDecl :: TcTypeEnv -> FamilyDecl Name -> TcM (Name, Kind)
+ generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name, fdTyVars = tyvars })
+ = generalise kind_env name tyvars
+
+mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
+mk_thing_env [] = []
+mk_thing_env (decl : decls)
+ | L _ (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) <- decl
+ = (nm, APromotionErr ClassPE) :
+ (map (, APromotionErr TyConPE) $ map (unLoc . fdLName . unLoc) ats) ++
+ (mk_thing_env decls)
+
+ | otherwise
+ = (tcdName (unLoc decl), APromotionErr TyConPE) :
+ (mk_thing_env decls)
+
getInitialKinds :: TopLevelFlag -> [LTyClDecl Name] -> TcM [(Name, TcTyThing)]
getInitialKinds top_lvl decls
- = tcExtendTcTyThingEnv [ (tcdName d, APromotionErr (mk_promotion_err d))
- | L _ d <- flattenTyClDecls decls] $
+ = tcExtendTcTyThingEnv (mk_thing_env decls) $
concatMapM (addLocM (getInitialKind top_lvl)) decls
- where
- mk_promotion_err (ClassDecl {}) = ClassPE
- mk_promotion_err _ = TyConPE
getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)]
-- Allocate a fresh kind variable for each TyCon and Class
@@ -333,31 +356,17 @@ getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)]
--
-- No family instances are passed to getInitialKinds
-getInitialKind top_lvl (TyFamily { tcdLName = L _ name, tcdTyVars = ktvs, tcdKindSig = ksig })
- | isTopLevel top_lvl
- = kcHsTyVarBndrs True ktvs $ \ arg_kinds ->
- do { res_k <- case ksig of
- Just k -> tcLHsKind k
- Nothing -> return liftedTypeKind
- ; let body_kind = mkArrowKinds arg_kinds res_k
- kvs = varSetElems (tyVarsOfType body_kind)
- ; return [ (name, AThing (mkForAllTys kvs body_kind)) ] }
-
- | otherwise
- = kcHsTyVarBndrs False ktvs $ \ arg_kinds ->
- do { res_k <- case ksig of
- Just k -> tcLHsKind k
- Nothing -> newMetaKindVar
- ; return [ (name, AThing (mkArrowKinds arg_kinds res_k)) ] }
-
+getInitialKind top_lvl (FamDecl { tcdFam = decl }) = getFamDeclInitialKind top_lvl decl
getInitialKind _ (ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
= kcHsTyVarBndrs False ktvs $ \ arg_kinds ->
- do { inner_prs <- getInitialKinds NotTopLevel ats
+ do { inner_prs <- getFamDeclInitialKinds ats
; let main_pr = (name, AThing (mkArrowKinds arg_kinds constraintKind))
; return (main_pr : inner_prs) }
-getInitialKind top_lvl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdTyDefn = defn })
- | TyData { td_kindSig = Just ksig, td_cons = cons } <- defn
+getInitialKind _top_lvl decl@(SynDecl {}) = pprPanic "getInitialKind" (ppr decl)
+
+getInitialKind top_lvl (DataDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdDataDefn = defn })
+ | HsDataDefn { dd_kindSig = Just ksig, dd_cons = cons } <- defn
= ASSERT( isTopLevel top_lvl )
kcHsTyVarBndrs True ktvs $ \ arg_kinds ->
do { res_k <- tcLHsKind ksig
@@ -368,7 +377,7 @@ getInitialKind top_lvl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcd
-- See Note [Recusion and promoting data constructors]
; return (main_pr : inner_prs) }
- | TyData { td_cons = cons } <- defn
+ | HsDataDefn { dd_cons = cons } <- defn
= kcHsTyVarBndrs False ktvs $ \ arg_kinds ->
do { let main_pr = (name, AThing (mkArrowKinds arg_kinds liftedTypeKind))
inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
@@ -376,11 +385,36 @@ getInitialKind top_lvl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcd
-- See Note [Recusion and promoting data constructors]
; return (main_pr : inner_prs) }
- | otherwise = pprPanic "getInitialKind" (ppr decl)
-
getInitialKind _ (ForeignType { tcdLName = L _ name })
= return [(name, AThing liftedTypeKind)]
+getFamDeclInitialKinds :: [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
+getFamDeclInitialKinds decls
+ = tcExtendTcTyThingEnv [ (n, APromotionErr TyConPE)
+ | L _ (FamilyDecl { fdLName = L _ n }) <- decls] $
+ concatMapM (addLocM (getFamDeclInitialKind NotTopLevel)) decls
+
+getFamDeclInitialKind :: TopLevelFlag
+ -> FamilyDecl Name
+ -> TcM [(Name, TcTyThing)]
+getFamDeclInitialKind top_lvl (FamilyDecl { fdLName = L _ name
+ , fdTyVars = ktvs
+ , fdKindSig = ksig })
+ | isTopLevel top_lvl
+ = kcHsTyVarBndrs True ktvs $ \ arg_kinds ->
+ do { res_k <- case ksig of
+ Just k -> tcLHsKind k
+ Nothing -> return liftedTypeKind
+ ; let body_kind = mkArrowKinds arg_kinds res_k
+ kvs = varSetElems (tyVarsOfType body_kind)
+ ; return [ (name, AThing (mkForAllTys kvs body_kind)) ] }
+
+ | otherwise
+ = kcHsTyVarBndrs False ktvs $ \ arg_kinds ->
+ do { res_k <- case ksig of
+ Just k -> tcLHsKind k
+ Nothing -> newMetaKindVar
+ ; return [ (name, AThing (mkArrowKinds arg_kinds res_k)) ] }
----------------
kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv -- Kind bindings
@@ -397,8 +431,8 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
-- of out-of-scope tycons
kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
-kcSynDecl decl@(TyDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
- , tcdTyDefn = TySynonym { td_synRhs = rhs } })
+kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
+ , tcdRhs = rhs })
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
kcHsTyVarBndrs False hs_tvs $ \ ks ->
@@ -422,32 +456,31 @@ kcTyClDecl :: TyClDecl Name -> TcM ()
-- result kind signature have aready been dealt with
-- by getInitialKind, so we can ignore them here.
-kcTyClDecl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = defn })
- | TyData { td_cons = cons, td_kindSig = Just _ } <- defn
- = mapM_ (wrapLocM kcConDecl) cons
+kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = defn })
+ | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn
+ = mapM_ (wrapLocM kcConDecl) cons
-- hs_tvs and td_kindSig already dealt with in getInitialKind
- -- Ignore the td_ctxt; heavily deprecated and inconvenient
+ -- Ignore the dd_ctxt; heavily deprecated and inconvenient
- | TyData { td_ctxt = ctxt, td_cons = cons } <- defn
- = kcTyClTyVars name hs_tvs $
+ | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn
+ = kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcConDecl) cons }
- | otherwise = pprPanic "kcTyClDecl" (ppr decl)
+kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl)
kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
- , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
- = kcTyClTyVars name hs_tvs $
+ , tcdCtxt = ctxt, tcdSigs = sigs })
+ = kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
- ; 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 (TyFamily {}) = return ()
kcTyClDecl (ForeignType {}) = return ()
+kcTyClDecl (FamDecl {}) = return ()
-------------------
kcConDecl :: ConDecl Name -> TcM ()
@@ -537,34 +570,22 @@ 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})
- = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
- { traceTc "type family:" (ppr tc_name)
- ; checkFamFlag tc_name
- ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False }
- ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent
- ; return [ATyCon tycon] }
-
- -- "data family" declaration
-tcTyClDecl1 parent _calc_isrec
- (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs})
- = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
- { traceTc "data family:" (ppr tc_name)
- ; checkFamFlag tc_name
- ; extra_tvs <- tcDataKindSig kind
- ; let final_tvs = tvs' ++ extra_tvs -- we may not need these
- tycon = buildAlgTyCon tc_name final_tvs Nothing []
- DataFamilyTyCon Recursive True parent
- ; return [ATyCon tycon] }
+tcTyClDecl1 parent _calc_isrec (FamDecl { tcdFam = fd })
+ = tcFamDecl1 parent fd
-- "type" synonym declaration
-tcTyClDecl1 _parent calc_isrec
- (TyDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdTyDefn = defn })
+tcTyClDecl1 _parent _calc_isrec
+ (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
+ = ASSERT( isNoParent _parent )
+ tcTyClTyVars tc_name tvs $ \ tvs' kind ->
+ tcTySynRhs tc_name tvs' kind rhs
+ -- "data/newtype" declaration
+tcTyClDecl1 _parent calc_isrec
+ (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
- tcTyDefn calc_isrec tc_name tvs' kind defn
+ tcDataDefn calc_isrec tc_name tvs' kind defn
tcTyClDecl1 _parent calc_isrec
(ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
@@ -634,11 +655,31 @@ tcTyClDecl1 _ _
\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 })
+tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing]
+tcFamDecl1 parent
+ (FamilyDecl {fdFlavour = TypeFamily, fdLName = L _ tc_name, fdTyVars = tvs})
+ = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+ { traceTc "type family:" (ppr tc_name)
+ ; checkFamFlag tc_name
+ ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False }
+ ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent
+ ; return [ATyCon tycon] }
+
+tcFamDecl1 parent
+ (FamilyDecl {fdFlavour = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs})
+ = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+ { traceTc "data family:" (ppr tc_name)
+ ; checkFamFlag tc_name
+ ; extra_tvs <- tcDataKindSig kind
+ ; let final_tvs = tvs' ++ extra_tvs -- we may not need these
+ tycon = buildAlgTyCon tc_name final_tvs Nothing []
+ DataFamilyTyCon Recursive True parent
+ ; return [ATyCon tycon] }
+
+tcTySynRhs :: Name
+ -> [TyVar] -> Kind
+ -> LHsType Name -> TcM [TyThing]
+tcTySynRhs tc_name tvs kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- tcCheckLHsType hs_ty kind
@@ -647,10 +688,14 @@ tcTyDefn _calc_isrec tc_name tvs kind (TySynonym { td_synRhs = hs_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 })
+tcDataDefn :: (Name -> RecFlag) -> Name
+ -> [TyVar] -> Kind
+ -> HsDataDefn Name -> TcM [TyThing]
+ -- NB: not used for newtype/data instances (whether associated or not)
+tcDataDefn calc_isrec tc_name tvs kind
+ (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = ctxt, dd_kindSig = mb_ksig
+ , dd_cons = cons })
= do { extra_tvs <- tcDataKindSig kind
; let is_rec = calc_isrec tc_name
final_tvs = tvs ++ extra_tvs
@@ -709,68 +754,93 @@ Note that:
\begin{code}
tcClassATs :: Name -- The class name (not knot-tied)
-> TyConParent -- The class parent of this associated type
- -> [LTyClDecl Name] -- Associated types. All FamTyCon
- -> [LFamInstDecl Name] -- Associated type defaults. All SynTyCon
+ -> [LFamilyDecl Name] -- Associated types.
+ -> [LTyFamInstDecl Name] -- Associated type defaults.
-> 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)
- | L _ n <- map (fid_tycon . unLoc) at_defs
+ | n <- map (tyFamInstDeclName . unLoc) at_defs
, not (n `elemNameSet` at_names) ]
; mapM tc_at ats }
where
- at_names = mkNameSet (map (tcdName . unLoc) ats)
+ at_names = mkNameSet (map (unLoc . fdLName . unLoc) ats)
- at_defs_map :: NameEnv [LFamInstDecl Name]
+ at_defs_map :: NameEnv [LTyFamInstDecl 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
- (famInstDeclName at_def) [at_def])
+ (tyFamInstDeclName (unLoc at_def)) [at_def])
emptyNameEnv at_defs
- tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent
- (const Recursive)) at
- ; let at_defs = lookupNameEnv at_defs_map (tcdName (unLoc at))
+ tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at
+ ; let at_defs = lookupNameEnv at_defs_map (unLoc $ fdLName $ unLoc at)
`orElse` []
- ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs
+ ; atd <- concatMapM (tcDefaultAssocDecl fam_tc) at_defs
; return (fam_tc, atd) }
-------------------------
-tcDefaultAssocDecl :: TyCon -- ^ Family TyCon
- -> LFamInstDecl Name -- ^ RHS
- -> TcM ATDefault -- ^ Type checked RHS and free TyVars
+tcDefaultAssocDecl :: TyCon -- ^ Family TyCon
+ -> LTyFamInstDecl Name -- ^ RHS
+ -> TcM [ATDefault] -- ^ Type checked RHS and free TyVars
tcDefaultAssocDecl fam_tc (L loc decl)
= setSrcSpan loc $
- tcAddFamInstCtxt decl $
+ tcAddTyFamInstCtxt 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) }
+ ; quads <- tcSynFamInstDecl fam_tc decl
+ ; return $ map (uncurry4 ATD) quads }
-- We check for well-formedness and validity later, in checkValidClass
+ where uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+ uncurry4 f (a, b, c, d) = f a b c d
-------------------------
-tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type)
+tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM [([TyVar], [Type], Type, SrcSpan)]
-- Placed here because type family instances appear as
-- default decls in class declarations
-tcSynFamInstDecl fam_tc
- (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym { td_synRhs = hs_ty }) })
- = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
- ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind ->
+tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqns = eqns })
+ -- we know the first equation matches the fam_tc because of the lookup logic
+ -- now, just check that all other names match the first
+ = do { let names = map (tfie_tycon . unLoc) eqns
+ first = head names
+ ; tcSynFamInstNames first names
+ ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
+ ; mapM (tcTyFamInstEqn fam_tc) eqns }
+
+-- Checks to make sure that all the names in an instance group are the same
+tcSynFamInstNames :: Located Name -> [Located Name] -> TcM ()
+tcSynFamInstNames (L _ first) names
+ = do { let badNames = filter ((/= first) . unLoc) names
+ ; mapM_ (failLocated (wrongNamesInInstGroup first)) badNames }
+ where failLocated :: (Name -> SDoc) -> Located Name -> TcM ()
+ failLocated msg_fun (L loc name)
+ = setSrcSpan loc $
+ failWithTc (msg_fun name)
+
+tcTyFamInstEqn :: TyCon -> LTyFamInstEqn Name -> TcM ([TyVar], [Type], Type, SrcSpan)
+tcTyFamInstEqn fam_tc
+ (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty }))
+ = setSrcSpan loc $
+ do { tcFamTyPats fam_tc pats (discardResult . (tcCheckLHsType hs_ty)) $
+ \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) } }
+ ; traceTc "tcSynFamInstEqn" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty))
+ ; return (tvs', pats', rhs_ty, loc) } }
-tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
-
-kcTyDefn :: HsTyDefn Name -> TcKind -> TcM ()
--- Used for 'data instance' and 'type instance' only
--- Ordinary 'data' and 'type' are handed by kcTyClDec and kcSynDecls resp
-kcTyDefn (TyData { td_ctxt = ctxt, td_cons = cons, td_kindSig = mb_kind }) res_k
+kcDataDefn :: HsDataDefn Name -> TcKind -> TcM ()
+-- Used for 'data instance' only
+-- Ordinary 'data' is handled by kcTyClDec
+kcDataDefn (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k
= do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcConDecl) cons
; kcResultKind mb_kind res_k }
+{- TODO remove
+kcTyRhs :: HsType Name ->
+-- Used for 'data instance' and 'type instance' only
+-- Ordinary 'data' and 'type' are handed by kcTyClDec and kcSynDecls resp
kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k
= discardResult (tcCheckLHsType rhs_ty res_k)
+-}
------------------
kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
@@ -1169,16 +1239,15 @@ checkClassCycleErrs cls
= unless (null cls_cycles) $ mapM_ recClsErr cls_cycles
where cls_cycles = calcClassCycles cls
-checkValidTyCl :: TyClDecl Name -> TcM ()
--- We do the validity check over declarations, rather than TyThings
--- only so that we can add a nice context with tcAddDeclCtxt
-checkValidTyCl decl
- = tcAddDeclCtxt decl $
- do { traceTc "Validity of 1" (ppr decl)
+checkValidDecl :: SDoc -- the context for error checking
+ -> Located Name -> TcM ()
+checkValidDecl ctxt lname
+ = addErrCtxt ctxt $
+ do { traceTc "Validity of 1" (ppr lname)
; env <- getGblEnv
; traceTc "Validity of 1a" (ppr (tcg_type_env env))
- ; thing <- tcLookupLocatedGlobal (tcdLName decl)
- ; traceTc "Validity of 2" (ppr decl)
+ ; thing <- tcLookupLocatedGlobal lname
+ ; traceTc "Validity of 2" (ppr lname)
; traceTc "Validity of" (ppr thing)
; case thing of
ATyCon tc -> do
@@ -1190,6 +1259,20 @@ checkValidTyCl decl
; traceTc "Done validity of" (ppr thing)
}
+checkValidTyCl :: TyClDecl Name -> TcM ()
+checkValidTyCl decl
+ = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl)
+ ; case decl of
+ ClassDecl { tcdATs = ats } ->
+ mapM_ (checkValidFamDecl . unLoc) ats
+ _ -> return () }
+
+checkValidFamDecl :: FamilyDecl Name -> TcM ()
+checkValidFamDecl (FamilyDecl { fdLName = lname, fdFlavour = flav })
+ = checkValidDecl (hsep [ptext (sLit "In the"), ppr flav,
+ ptext (sLit "declaration for"), quotes (ppr lname)])
+ lname
+
-------------------------
-- For data types declared with record syntax, we require
-- that each constructor that has a field 'f'
@@ -1683,13 +1766,25 @@ 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
+tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
+tcAddFamInstCtxt flavour tycon thing_inside
= addErrCtxt ctxt thing_inside
where
- ctxt = hsep [ptext (sLit "In the") <+> pprTyDefnFlavour defn
- <+> ptext (sLit "instance declaration for"),
- quotes (ppr tc)]
+ ctxt = hsep [ptext (sLit "In the") <+> flavour
+ <+> ptext (sLit "declaration for"),
+ quotes (ppr tycon)]
+
+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
+ = tcAddFamInstCtxt ((pprDataFamInstFlavour decl) <+> (ptext (sLit "instance")))
+ (unLoc (dfid_tycon decl))
resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
resultTypeMisMatch field_name con1 con2
@@ -1831,4 +1926,11 @@ wrongKindOfFamily family
kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
| isAlgTyCon family = ptext (sLit "data type")
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
+
+wrongNamesInInstGroup :: Name -> Name -> SDoc
+wrongNamesInInstGroup first cur
+ = ptext (sLit "Mismatched family names in instance group.") $$
+ ptext (sLit "First name was") <+>
+ (ppr first) <> (ptext (sLit "; this one is")) <+> (ppr cur)
+
\end{code}
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 3df8209eed2dc18cd0161d6bc54d3fd32ed8bcea..6818c025a27312ef7b49c8901610ff35b7c02034 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -110,7 +110,7 @@ synTyConsOfType ty
\begin{code}
mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])]
mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs)
- | ldecl@(L _ (TyDecl { tcdLName = L _ name
+ | ldecl@(L _ (SynDecl { tcdLName = L _ name
, tcdFVs = fvs })) <- syn_decls ]
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 6ab10401829c898d893a8dcf52857622ac52c3e6..8c8cb9a984e5107da2fcdea45d5571839cdb5480 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -76,6 +76,7 @@ module TcType (
-- Misc type manipulators
deNoteType, occurCheckExpand, OccCheckResult(..),
orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
+ orphNamesOfCoCon,
getDFunTyKey,
evVarPred_maybe, evVarPred,
@@ -173,6 +174,7 @@ import VarSet
import Coercion
import Type
import TyCon
+import CoAxiom
-- others:
import DynFlags
@@ -648,8 +650,8 @@ tidyCo env@(_, subst) co
go (CoVarCo cv) = case lookupVarEnv subst cv of
Nothing -> CoVarCo cv
Just cv' -> CoVarCo cv'
- go (AxiomInstCo con cos) = let args = tidyCos env cos
- in args `seqList` AxiomInstCo con args
+ go (AxiomInstCo con ind cos) = let args = tidyCos env cos
+ in args `seqList` AxiomInstCo con ind args
go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
go (SymCo co) = SymCo $! go co
go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
@@ -1462,8 +1464,11 @@ orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNa
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
+orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
+orphNamesOfThings f = foldr (unionNameSets . f) emptyNameSet
+
orphNamesOfTypes :: [Type] -> NameSet
-orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
+orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfDFunHead :: Type -> NameSet
-- Find the free type constructors and classes
@@ -1482,7 +1487,7 @@ orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` o
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
-orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
@@ -1491,11 +1496,18 @@ orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
orphNamesOfCos :: [Coercion] -> NameSet
-orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
+orphNamesOfCos = orphNamesOfThings orphNamesOfCo
+
+orphNamesOfCoCon :: CoAxiom br -> NameSet
+orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
+ = orphNamesOfTyCon tc `unionNameSets` orphNamesOfCoAxBranches branches
+
+orphNamesOfCoAxBranches :: BranchList CoAxBranch br -> NameSet
+orphNamesOfCoAxBranches = brListFoldr (unionNameSets . orphNamesOfCoAxBranch) emptyNameSet
-orphNamesOfCoCon :: CoAxiom -> NameSet
-orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
- = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
+orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
+ = orphNamesOfTypes lhs `unionNameSets` orphNamesOfType rhs
\end{code}
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index c70f16dbc62632aec76c2870899c73439887f084..6ceb7799cd6dd082a3cb072b0a1b0ead96d5f2d0 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -101,7 +101,7 @@ type ClassATItem = (TyCon, -- See Note [Associated type tyvar names]
-- We can have more than one default per type; see
-- Note [Associated type defaults] in TcTyClsDecls
--- Each associated type default template is a triple of:
+-- Each associated type default template is a quad of:
data ATDefault = ATD { -- TyVars of the RHS and family arguments
-- (including, but perhaps more than, the class TVs)
atDefaultTys :: [TyVar],
diff --git a/compiler/types/CoAxiom.lhs b/compiler/types/CoAxiom.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..b4cd090aa2634a03ef3f4b1336bbd61b761253a1
--- /dev/null
+++ b/compiler/types/CoAxiom.lhs
@@ -0,0 +1,292 @@
+%
+% (c) The University of Glasgow 2012
+%
+
+\begin{code}
+
+{-# LANGUAGE GADTs #-}
+
+-- | Module for coercion axioms, used to represent type family instances
+-- and newtypes
+
+module CoAxiom (
+ Branched, Unbranched, BranchList(..),
+ toBranchList, fromBranchList,
+ toBranchedList, toUnbranchedList,
+ brListLength, brListNth, brListMap, brListFoldr,
+ brListZipWith,
+
+ CoAxiom(..), CoAxBranch(..),
+
+ toBranchedAxiom, toUnbranchedAxiom,
+ coAxiomName, coAxiomArity, coAxiomBranches,
+ coAxiomTyCon, isImplicitCoAxiom,
+ coAxiomNthBranch, coAxiomSingleBranch_maybe,
+ coAxiomSingleBranch, coAxBranchTyVars, coAxBranchLHS,
+ coAxBranchRHS
+ ) where
+
+import {-# SOURCE #-} TypeRep ( Type )
+import {-# SOURCE #-} TyCon ( TyCon )
+import Outputable
+import Name
+import Unique
+import Var
+import Util
+import BasicTypes
+import Data.Typeable ( Typeable )
+import qualified Data.Data as Data
+
+#include "HsVersions.h"
+
+\end{code}
+
+%************************************************************************
+%* *
+ Coercion axioms
+%* *
+%************************************************************************
+
+Note [Coercion axiom branches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to allow type family instance groups, an axiom needs to contain an
+ordered list of alternatives, called branches. The kind of the coercion built
+from an axiom is determined by which index is used when building the coercion
+from the axiom.
+
+For example, consider the axiom derived from the following declaration:
+
+type instance where
+ F [Int] = Bool
+ F [a] = Double
+ F (a b) = Char
+
+This will give rise to this axiom:
+
+axF :: { F [Int] ~ Bool
+ ; forall (a :: *). F [a] ~ Double
+ ; forall (k :: BOX) (a :: k -> *) (b :: k). F (a b) ~ Char
+ }
+
+The axiom is used with the AxiomInstCo constructor of Coercion. If we wish
+to have a coercion showing that F (Maybe Int) ~ Char, it will look like
+
+axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char
+-- or, written using concrete-ish syntax --
+AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]
+
+Note that the index is 0-based.
+
+For type-checking, it is also necessary to check that no previous pattern
+can unify with the supplied arguments. After all, it is possible that some
+of the type arguments are lambda-bound type variables whose instantiation may
+cause an earlier match among the branches. We wish to prohibit this behavior,
+so the type checker rules out the choice of a branch where a previous branch
+can unify. See also [Instance checking within groups] in FamInstEnv.hs.
+
+For example, the following is malformed, where 'a' is a lambda-bound type
+variable:
+
+axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char
+
+Why? Because a might be instantiated with [], meaning that branch 1 should
+apply, not branch 2. This is a vital consistency check; without it, we could
+derive Int ~ Bool, and that is a Bad Thing.
+
+Note [Branched axioms]
+~~~~~~~~~~~~~~~~~~~~~~~
+Although a CoAxiom has the capacity to store many branches, in certain cases,
+we want only one. These cases are in data/newtype family instances, newtype
+coercions, and type family instances declared with "type instance ...", not
+"type instance where". Furthermore, these unbranched axioms are used in a
+variety of places throughout GHC, and it would difficult to generalize all of
+that code to deal with branched axioms, especially when the code can be sure
+of the fact that an axiom is indeed a singleton. At the same time, it seems
+dangerous to assume singlehood in various places through GHC.
+
+The solution to this is to label a CoAxiom (and FamInst) with a phantom
+type variable declaring whether it is known to be a singleton or not. The
+list of branches is stored using a special form of list, declared below,
+that ensures that the type variable is accurate.
+
+As of this writing (Dec 2012), it would not be appropriate to use a promoted
+type as the phantom type, so we use empty datatypes. We wish to have GHC
+remain compilable with GHC 7.2.1. If you are revising this code and GHC no
+longer needs to remain compatible with GHC 7.2.x, then please update this
+code to use promoted types.
+
+\begin{code}
+
+-- the phantom type labels
+data Unbranched deriving Typeable
+data Branched deriving Typeable
+
+data BranchList a br where
+ FirstBranch :: a -> BranchList a br
+ NextBranch :: a -> BranchList a br -> BranchList a Branched
+
+-- convert to/from lists
+toBranchList :: [a] -> BranchList a Branched
+toBranchList [] = pprPanic "toBranchList" empty
+toBranchList [b] = FirstBranch b
+toBranchList (h:t) = NextBranch h (toBranchList t)
+
+fromBranchList :: BranchList a br -> [a]
+fromBranchList (FirstBranch b) = [b]
+fromBranchList (NextBranch h t) = h : (fromBranchList t)
+
+-- convert from any BranchList to a Branched BranchList
+toBranchedList :: BranchList a br -> BranchList a Branched
+toBranchedList (FirstBranch b) = FirstBranch b
+toBranchedList (NextBranch h t) = NextBranch h t
+
+-- convert from any BranchList to an Unbranched BranchList
+toUnbranchedList :: BranchList a br -> BranchList a Unbranched
+toUnbranchedList (FirstBranch b) = FirstBranch b
+toUnbranchedList _ = pprPanic "toUnbranchedList" empty
+
+-- length
+brListLength :: BranchList a br -> Int
+brListLength (FirstBranch _) = 1
+brListLength (NextBranch _ t) = 1 + brListLength t
+
+-- lookup
+brListNth :: BranchList a br -> Int -> a
+brListNth (FirstBranch b) 0 = b
+brListNth (NextBranch h _) 0 = h
+brListNth (NextBranch _ t) n = brListNth t (n-1)
+brListNth _ _ = pprPanic "brListNth" empty
+
+-- map, fold
+brListMap :: (a -> b) -> BranchList a br -> [b]
+brListMap f (FirstBranch b) = [f b]
+brListMap f (NextBranch h t) = f h : (brListMap f t)
+
+brListFoldr :: (a -> b -> b) -> b -> BranchList a br -> b
+brListFoldr f x (FirstBranch b) = f b x
+brListFoldr f x (NextBranch h t) = f h (brListFoldr f x t)
+
+-- zipWith
+brListZipWith :: (a -> b -> c) -> BranchList a br1 -> BranchList b br2 -> [c]
+brListZipWith f (FirstBranch a) (FirstBranch b) = [f a b]
+brListZipWith f (FirstBranch a) (NextBranch b _) = [f a b]
+brListZipWith f (NextBranch a _) (FirstBranch b) = [f a b]
+brListZipWith f (NextBranch a ta) (NextBranch b tb) = f a b : brListZipWith f ta tb
+
+-- pretty-printing
+
+instance Outputable a => Outputable (BranchList a br) where
+ ppr = ppr . fromBranchList
+
+-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
+data CoAxiom br
+ = CoAxiom -- Type equality axiom.
+ { co_ax_unique :: Unique -- unique identifier
+ , co_ax_name :: Name -- name for pretty-printing
+ , co_ax_tc :: TyCon -- the head of the LHS patterns
+ , co_ax_branches :: BranchList CoAxBranch br
+ -- the branches that form this axiom
+ , co_ax_implicit :: Bool -- True <=> the axiom is "implicit"
+ -- See Note [Implicit axioms]
+ -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.
+ }
+ deriving Typeable
+
+data CoAxBranch
+ = CoAxBranch
+ { cab_tvs :: [TyVar] -- bound type variables
+ , cab_lhs :: [Type] -- type patterns to match against
+ , cab_rhs :: Type -- right-hand side of the equality
+ }
+ deriving Typeable
+
+toBranchedAxiom :: CoAxiom br -> CoAxiom Branched
+toBranchedAxiom (CoAxiom unique name tc branches implicit)
+ = CoAxiom unique name tc (toBranchedList branches) implicit
+
+toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched
+toUnbranchedAxiom (CoAxiom unique name tc branches implicit)
+ = CoAxiom unique name tc (toUnbranchedList branches) implicit
+
+coAxiomNthBranch :: CoAxiom br -> Int -> CoAxBranch
+coAxiomNthBranch ax index
+ = ASSERT( 0 <= index && index < (length $ fromBranchList (co_ax_branches ax)) )
+ (fromBranchList $ co_ax_branches ax) !! index
+
+coAxiomArity :: CoAxiom br -> Int -> Arity
+coAxiomArity ax index
+ = length $ cab_tvs $ coAxiomNthBranch ax index
+
+coAxiomName :: CoAxiom br -> Name
+coAxiomName = co_ax_name
+
+coAxiomBranches :: CoAxiom br -> BranchList CoAxBranch br
+coAxiomBranches = co_ax_branches
+
+coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch
+coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = branches })
+ | FirstBranch br <- branches
+ = Just br
+ | otherwise
+ = Nothing
+
+coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch
+coAxiomSingleBranch (CoAxiom { co_ax_branches = FirstBranch br }) = br
+
+coAxiomTyCon :: CoAxiom br -> TyCon
+coAxiomTyCon = co_ax_tc
+
+coAxBranchTyVars :: CoAxBranch -> [TyVar]
+coAxBranchTyVars = cab_tvs
+
+coAxBranchLHS :: CoAxBranch -> [Type]
+coAxBranchLHS = cab_lhs
+
+coAxBranchRHS :: CoAxBranch -> Type
+coAxBranchRHS = cab_rhs
+
+isImplicitCoAxiom :: CoAxiom br -> Bool
+isImplicitCoAxiom = co_ax_implicit
+\end{code}
+
+Note [Implicit axioms]
+~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Implicit TyThings] in HscTypes
+* A CoAxiom arising from data/type family instances is not "implicit".
+ That is, it has its own IfaceAxiom declaration in an interface file
+
+* The CoAxiom arising from a newtype declaration *is* "implicit".
+ That is, it does not have its own IfaceAxiom declaration in an
+ interface file; instead the CoAxiom is generated by type-checking
+ the newtype declaration
+
+\begin{code}
+instance Eq (CoAxiom br) where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord (CoAxiom br) where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = getUnique a `compare` getUnique b
+
+instance Uniquable (CoAxiom br) where
+ getUnique = co_ax_unique
+
+instance Outputable (CoAxiom br) where
+ ppr = ppr . getName
+
+instance NamedThing (CoAxiom br) where
+ getName = co_ax_name
+
+instance Typeable br => Data.Data (CoAxiom br) where
+ -- don't traverse?
+ toConstr _ = abstractConstr "CoAxiom"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "CoAxiom"
+\end{code}
\ No newline at end of file
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 1ba6412bee3c80c435a251481b50eed2b39ae9ab..0c3dfd6dc8c83d4a255a162009c32d43548a551e 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -25,12 +25,10 @@ module Coercion (
isReflCo_maybe,
mkCoercionType,
- -- ** Functions over coercion axioms
- coAxiomSplitLHS,
-
-- ** Constructing coercions
mkReflCo, mkCoVarCo,
- mkAxInstCo, mkAxInstRHS,
+ mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstRHS,
+ mkUnbranchedAxInstRHS,
mkPiCo, mkPiCos, mkCoCast,
mkSymCo, mkTransCo, mkNthCo, mkLRCo,
mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
@@ -84,6 +82,7 @@ import TypeRep
import qualified Type
import Type hiding( substTy, substTyVarBndr, extendTvSubst )
import TyCon
+import CoAxiom
import Var
import VarEnv
import VarSet
@@ -143,9 +142,10 @@ data Coercion
-- These are special
| CoVarCo CoVar
- | AxiomInstCo CoAxiom [Coercion] -- The coercion arguments always *precisely*
- -- saturate arity of CoAxiom.
- -- See [Coercion axioms applied to coercions]
+ | AxiomInstCo (CoAxiom Branched) Int [Coercion]
+ -- The coercion arguments always *precisely* saturate arity of CoAxiom.
+ -- See [Coercion axioms applied to coercions]
+ -- See also [CoAxiom index]
| UnsafeCo Type Type
| SymCo Coercion
| TransCo Coercion Coercion
@@ -222,6 +222,18 @@ Now we have
which can be optimized to F g.
+Note [CoAxiom index]
+~~~~~~~~~~~~~~~~~~~~
+A CoAxiom has 1 or more branches. Each branch has contains a list
+of the free type variables in that branch, the LHS type patterns,
+and the RHS type for that branch. When we apply an axiom to a list
+of coercions, we must choose which branch of the axiom we wish to
+use, as the different branches may have different numbers of free
+type variables. (The number of type patterns is always the same
+among branches, but that doesn't quite concern us here.)
+
+The Int in the AxiomInstCo constructor is the 0-indexed number
+of the chosen branch.
Note [Forall coercions]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -292,24 +304,6 @@ may turn into
C (Nth 0 g) ....
Now (Nth 0 g) will optimise to Refl, but perhaps not instantly.
-
-%************************************************************************
-%* *
-\subsection{Coercion axioms}
-%* *
-%************************************************************************
-These functions are not in TyCon because they need knowledge about
-the type representation (from TypeRep)
-
-\begin{code}
--- If `ax :: F a ~ b`, and `F` is a family instance, returns (F, [a])
-coAxiomSplitLHS :: CoAxiom -> (TyCon, [Type])
-coAxiomSplitLHS ax
- = case splitTyConApp_maybe (coAxiomLHS ax) of
- Just (tc,tys) -> (tc,tys)
- Nothing -> pprPanic "coAxiomSplitLHS" (ppr ax)
-\end{code}
-
%************************************************************************
%* *
\subsection{Coercion variables}
@@ -345,7 +339,7 @@ tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos
tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv
tyCoVarsOfCo (CoVarCo v) = unitVarSet v
-tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (AxiomInstCo _ _ cos) = tyCoVarsOfCos cos
tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co
tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
@@ -363,7 +357,7 @@ coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos
coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
coVarsOfCo (ForAllCo _ co) = coVarsOfCo co
coVarsOfCo (CoVarCo v) = unitVarSet v
-coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos
+coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos
coVarsOfCo (UnsafeCo _ _) = emptyVarSet
coVarsOfCo (SymCo co) = coVarsOfCo co
coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
@@ -380,7 +374,7 @@ coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos)
coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2
coercionSize (ForAllCo _ co) = 1 + coercionSize co
coercionSize (CoVarCo _) = 1
-coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos)
coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2
coercionSize (SymCo co) = 1 + coercionSize co
coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
@@ -420,7 +414,10 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $
pprCo co1 <+> ppr_co TyConPrec co2
ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
-ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
+ppr_co p (AxiomInstCo con index cos)
+ = angleBrackets (pprPrefixApp p
+ (ppr (getName con) <> brackets (ppr index))
+ (map (ppr_co TyConPrec) cos))
ppr_co p co@(TransCo {}) = maybeParen p FunPrec $
case trans_co_list co [] of
@@ -464,11 +461,16 @@ ppr_forall_co p ty
\end{code}
\begin{code}
-pprCoAxiom :: CoAxiom -> SDoc
-pprCoAxiom ax
- = sep [ ptext (sLit "axiom") <+>
- sep [ ppr ax, nest 2 (pprTvBndrs (co_ax_tvs ax)) ]
- , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ]
+pprCoAxiom :: CoAxiom br -> SDoc
+pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
+ = hang (ptext (sLit "axiom") <+> ppr ax <+> dcolon)
+ 2 (vcat (map (pprCoAxBranch tc) $ fromBranchList branches))
+
+pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
+pprCoAxBranch tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
+ = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot <+>
+ pprEqPred (Pair (mkTyConApp tc lhs) rhs)
+
\end{code}
%************************************************************************
@@ -559,31 +561,41 @@ mkCoVarCo cv
mkReflCo :: Type -> Coercion
mkReflCo = Refl
-mkAxInstCo :: CoAxiom -> [Type] -> Coercion
+mkAxInstCo :: CoAxiom br -> Int -> [Type] -> Coercion
-- mkAxInstCo can legitimately be called over-staturated;
-- i.e. with more type arguments than the coercion requires
-mkAxInstCo ax tys
- | arity == n_tys = AxiomInstCo ax rtys
+mkAxInstCo ax index tys
+ | arity == n_tys = AxiomInstCo ax_br index rtys
| otherwise = ASSERT( arity < n_tys )
- foldl AppCo (AxiomInstCo ax (take arity rtys))
+ foldl AppCo (AxiomInstCo ax_br index (take arity rtys))
(drop arity rtys)
where
n_tys = length tys
- arity = coAxiomArity ax
+ arity = coAxiomArity ax index
rtys = map Refl tys
+ ax_br = toBranchedAxiom ax
+
+-- to be used only with unbranched axioms
+mkUnbranchedAxInstCo :: CoAxiom Unbranched -> [Type] -> Coercion
+mkUnbranchedAxInstCo ax tys
+ = mkAxInstCo ax 0 tys
-mkAxInstRHS :: CoAxiom -> [Type] -> Type
+mkAxInstRHS :: CoAxiom br -> Int -> [Type] -> Type
-- Instantiate the axiom with specified types,
-- returning the instantiated RHS
-- A companion to mkAxInstCo:
--- mkAxInstRhs ax tys = snd (coercionKind (mkAxInstCo ax tys))
-mkAxInstRHS ax tys
+-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))
+mkAxInstRHS ax index tys
= ASSERT( tvs `equalLength` tys1 )
mkAppTys rhs' tys2
where
- tvs = coAxiomTyVars ax
+ branch = coAxiomNthBranch ax index
+ tvs = coAxBranchTyVars branch
(tys1, tys2) = splitAtList tvs tys
- rhs' = substTyWith tvs tys1 (coAxiomRHS ax)
+ rhs' = substTyWith tvs tys1 (coAxBranchRHS branch)
+
+mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type
+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0
-- | Apply a 'Coercion' to another 'Coercion'.
mkAppCo :: Coercion -> Coercion -> Coercion
@@ -686,14 +698,16 @@ mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
-- the type the appropriate right hand side of the @newtype@, with
-- the free variables a subset of those 'TyVar's.
-mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom
+mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom Unbranched
mkNewTypeCo name tycon tvs rhs_ty
= CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
, co_ax_implicit = True -- See Note [Implicit axioms] in TyCon
- , co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
- , co_ax_rhs = rhs_ty }
+ , co_ax_tc = tycon
+ , co_ax_branches = FirstBranch branch }
+ where branch = CoAxBranch { cab_tvs = tvs
+ , cab_lhs = mkTyVarTys tvs
+ , cab_rhs = rhs_ty }
mkPiCos :: [Var] -> Coercion -> Coercion
mkPiCos vs co = foldr mkPiCo co vs
@@ -729,7 +743,7 @@ instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe tc tys
| Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc
= ASSERT( tys `lengthIs` tyConArity tc )
- Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys)
+ Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo co_tc tys)
| otherwise
= Nothing
@@ -773,8 +787,9 @@ coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2)
coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2)
= rnOccL env cv1 == rnOccR env cv2
-coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2)
+coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2)
= con1 == con2
+ && ind1 == ind2
&& all2 (coreEqCoercion2 env) cos1 cos2
coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22)
@@ -926,7 +941,7 @@ subst_co subst co
(subst', tv') ->
ForAllCo tv' $! subst_co subst' co
go (CoVarCo cv) = substCoVar subst cv
- go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos
+ go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos
go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2
go (SymCo co) = mkSymCo (go co)
go (TransCo co1 co2) = mkTransCo (go co1) (go co2)
@@ -1100,7 +1115,7 @@ seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos
seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
seqCo (ForAllCo tv co) = tv `seq` seqCo co
seqCo (CoVarCo cv) = cv `seq` ()
-seqCo (AxiomInstCo con cos) = con `seq` seqCos cos
+seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos
seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2
seqCo (SymCo co) = seqCo co
seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2
@@ -1140,9 +1155,12 @@ coercionKind co = go co
go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2
go (ForAllCo tv co) = mkForAllTy tv <$> go co
go (CoVarCo cv) = toPair $ coVarKind cv
- go (AxiomInstCo ax cos) = let Pair tys1 tys2 = sequenceA $ map go cos
- in Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax))
- (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
+ go (AxiomInstCo ax ind cos)
+ = let branch = coAxiomNthBranch ax ind
+ tvs = coAxBranchTyVars branch
+ Pair tys1 tys2 = sequenceA $ map go cos
+ in Pair (substTyWith tvs tys1 (coAxNthLHS ax ind))
+ (substTyWith tvs tys2 (coAxBranchRHS branch))
go (UnsafeCo ty1 ty2) = Pair ty1 ty2
go (SymCo co) = swap $ go co
go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2)
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 88ab09810a136e6069646658c2924910080f1e2f..cc432a20caa4b19c50f3ab8b53fb6fd54cbc7fab 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -6,17 +6,28 @@ FamInstEnv: Type checked family instance declarations
\begin{code}
module FamInstEnv (
- FamInst(..), FamFlavor(..), famInstAxiom,
- famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,
- famInstLHS,
- pprFamInst, pprFamInstHdr, pprFamInsts,
- mkSynFamInst, mkDataFamInst, mkImportedFamInst,
-
- FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
- extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList,
- identicalFamInst, famInstEnvElts, familyInstances,
-
+ Branched, Unbranched,
+
+ FamInst(..), FamFlavor(..), FamInstBranch(..),
+ famInstAxiom, famInstBranchRoughMatch,
+ famInstsRepTyCons, famInstNthBranch, famInstSingleBranch,
+ famInstBranchLHS, famInstBranches, famInstBranchSpan,
+ toBranchedFamInst, toUnbranchedFamInst,
+ famInstTyCon, famInstRepTyCon_maybe, dataFamInstRepTyCon,
+ pprFamInst, pprFamInsts, pprFamInstBranch, pprFamInstBranches,
+ pprFamFlavor, pprFamInstBranchHdr,
+ mkSynFamInst, mkSynFamInstBranch, mkSingleSynFamInst,
+ mkDataFamInst, mkImportedFamInst,
+
+ FamInstEnv, FamInstEnvs,
+ emptyFamInstEnvs, emptyFamInstEnv, famInstEnvElts, familyInstances,
+ extendFamInstEnvList, extendFamInstEnv, deleteFromFamInstEnv,
+ identicalFamInst,
+
+ FamInstMatch(..),
lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts',
+
+ isDominatedBy,
-- Normalisation
topNormaliseType, normaliseType, normaliseTcApp
@@ -27,9 +38,10 @@ module FamInstEnv (
import InstEnv
import Unify
import Type
+import Coercion hiding ( substTy )
import TypeRep
import TyCon
-import Coercion
+import CoAxiom
import VarSet
import VarEnv
import Name
@@ -38,6 +50,7 @@ import Outputable
import Maybes
import Util
import FastString
+import SrcLoc
\end{code}
@@ -59,35 +72,67 @@ Note [FamInsts and CoAxioms]
- The FamInst contains a CoAxiom, which is the evidence
for the instance
- - The LHS of the CoAxiom is always of form F ty1 .. tyn
- where F is a type family
-
+ - The LHSs of the CoAxiom branches are always of form
+ F ty1 .. tyn where F is a type family
+
+* A FamInstBranch corresponds to a CoAxBranch -- it represents
+ one alternative in a family instance group. We could theoretically
+ not have FamInstBranches and just use the CoAxBranches within
+ the CoAxiom stored in the FamInst, but for one problem: we want to
+ cache the "rough match" top-level tycon names for quick matching.
+ This data is not stored in a CoAxBranch, so we use FamInstBranches
+ instead.
+
+Note [FamInst locations]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The source location of a FamInst is stored in two places in the datatype
+tree. The first is in the location info buried in the Name of the
+underlying CoAxiom. This span includes all of the branches of a branched
+FamInst/CoAxiom. The second is in the fib_loc fields of the FamInstBranches.
+In the case of a single branch, we can extract the source location of the
+branch from the name of the CoAxiom. In other cases, we need an explicit
+SrcSpan to correctly store the location of the equation giving rise to
+the FamInstBranch.
+
+Note [fi_group field]
+~~~~~~~~~~~~~~~~~~~~~
+A FamInst stores whether or not it was declared with "type instance where"
+for two reasons: 1. for accurate pretty-printing; and 2. because confluent
+overlap is disallowed between branches declared in groups. Note that this
+"group-ness" is properly associated with the FamInst, which thinks about
+overlap, and not in the CoAxiom, which blindly assumes that it is part of
+a consistent axiom set.
\begin{code}
-data FamInst -- See Note [FamInsts and CoAxioms]
- = FamInst { fi_axiom :: CoAxiom -- The new coercion axiom introduced
- -- by this family instance
- , fi_flavor :: FamFlavor
+data FamInst br -- See Note [FamInsts and CoAxioms], Note [Branched axioms] in CoAxiom.lhs
+ = FamInst { fi_axiom :: CoAxiom br -- The new coercion axiom introduced
+ -- by this family instance
+ , fi_flavor :: FamFlavor
+ , fi_group :: Bool -- True <=> declared with "type instance where"
+ -- See Note [fi_group field]
-- Everything below here is a redundant,
-- cached version of the two things above
- , fi_fam :: Name -- Family name
- -- INVARIANT: fi_fam = name of fi_fam_tc
-
- -- Used for "rough matching"; same idea as for class instances
- -- See Note [Rough-match field] in InstEnv
- , fi_tcs :: [Maybe Name] -- Top of type args
- -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
-
- -- Used for "proper matching"; ditto
- , fi_tvs :: TyVarSet -- Template tyvars for full match
- , fi_fam_tc :: TyCon -- Family tycon
- , fi_tys :: [Type] -- and its arg types
- -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom
- -- (fi_fam_tc, fi_tys) = coAxiomSplitLHS fi_axiom
+ , fi_branches :: BranchList FamInstBranch br
+ -- Haskell-source-language view of
+ -- a CoAxBranch
+ , fi_fam :: Name -- Family name
+ -- INVARIANT: fi_fam = name of fi_axiom.co_ax_tc
}
-data FamFlavor
+data FamInstBranch
+ = FamInstBranch
+ { fib_loc :: SrcSpan -- location of this equation
+ -- See Note [FamInst locations]
+
+ , fib_tvs :: TyVarSet -- bound type variables
+ , fib_lhs :: [Type] -- type patterns
+ , fib_rhs :: Type -- RHS of family instance
+ , fib_tcs :: [Maybe Name] -- used for "rough matching" during typechecking
+ -- see Note [Rough-match field] in InstEnv
+ }
+
+data FamFlavor
= SynFamilyInst -- A synonym family
| DataFamilyInst TyCon -- A data family, with its representation TyCon
\end{code}
@@ -95,24 +140,60 @@ data FamFlavor
\begin{code}
-- Obtain the axiom of a family instance
-famInstAxiom :: FamInst -> CoAxiom
+famInstAxiom :: FamInst br -> CoAxiom br
famInstAxiom = fi_axiom
-famInstLHS :: FamInst -> (TyCon, [Type])
-famInstLHS (FamInst { fi_fam_tc = tc, fi_tys = tys }) = (tc, tys)
+famInstTyCon :: FamInst br -> TyCon
+famInstTyCon = co_ax_tc . fi_axiom
+
+famInstNthBranch :: FamInst br -> Int -> FamInstBranch
+famInstNthBranch (FamInst { fi_branches = branches }) index
+ = ASSERT( 0 <= index && index < (length $ fromBranchList branches) )
+ brListNth branches index
+
+famInstSingleBranch :: FamInst Unbranched -> FamInstBranch
+famInstSingleBranch (FamInst { fi_branches = FirstBranch branch }) = branch
+
+toBranchedFamInst :: FamInst br -> FamInst Branched
+toBranchedFamInst (FamInst ax flav grp branches fam)
+ = FamInst (toBranchedAxiom ax) flav grp (toBranchedList branches) fam
+
+toUnbranchedFamInst :: FamInst br -> FamInst Unbranched
+toUnbranchedFamInst (FamInst ax flav grp branches fam)
+ = FamInst (toUnbranchedAxiom ax) flav grp (toUnbranchedList branches) fam
+
+famInstBranches :: FamInst br -> BranchList FamInstBranch br
+famInstBranches = fi_branches
+
+famInstBranchLHS :: FamInstBranch -> [Type]
+famInstBranchLHS = fib_lhs
+
+famInstBranchRoughMatch :: FamInstBranch -> [Maybe Name]
+famInstBranchRoughMatch = fib_tcs
+
+famInstBranchSpan :: FamInstBranch -> SrcSpan
+famInstBranchSpan = fib_loc
+
+-- returns True means the famInst will match all applications
+-- returning False gives no information
+famInstMatchesAny :: FamInst br -> Bool
+famInstMatchesAny (FamInst { fi_branches = branches })
+ = brListAny (all isNothing . fib_tcs) branches
+ where brListAny :: (a -> Bool) -> BranchList a br -> Bool
+ brListAny f ls = brListFoldr (\branch rest -> rest || f branch) False ls
-- Return the representation TyCons introduced by data family instances, if any
-famInstsRepTyCons :: [FamInst] -> [TyCon]
+famInstsRepTyCons :: [FamInst br] -> [TyCon]
famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]
-- Extracts the TyCon for this *data* (or newtype) instance
-famInstRepTyCon_maybe :: FamInst -> Maybe TyCon
+famInstRepTyCon_maybe :: FamInst br -> Maybe TyCon
famInstRepTyCon_maybe fi
= case fi_flavor fi of
DataFamilyInst tycon -> Just tycon
SynFamilyInst -> Nothing
-dataFamInstRepTyCon :: FamInst -> TyCon
+dataFamInstRepTyCon :: FamInst br -> TyCon
dataFamInstRepTyCon fi
= case fi_flavor fi of
DataFamilyInst tycon -> tycon
@@ -120,74 +201,141 @@ dataFamInstRepTyCon fi
\end{code}
\begin{code}
-instance NamedThing FamInst where
+instance NamedThing (FamInst br) where
getName = coAxiomName . fi_axiom
-instance Outputable FamInst where
+instance Outputable (FamInst br) where
ppr = pprFamInst
-- Prints the FamInst as a family instance declaration
-pprFamInst :: FamInst -> SDoc
-pprFamInst famInst
- = hang (pprFamInstHdr famInst)
- 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax)
- , ifPprDebug (ptext (sLit "RHS:") <+> ppr (coAxiomRHS ax))
- , ptext (sLit "--") <+> pprDefinedAt (getName famInst)])
+pprFamInst :: FamInst br -> SDoc
+pprFamInst (FamInst { fi_branches = brs, fi_flavor = SynFamilyInst
+ , fi_group = True, fi_axiom = axiom })
+ = hang (ptext (sLit "type instance where"))
+ 2 (vcat (brListMap (pprFamInstBranchHdr axiom) brs))
+
+pprFamInst fi@(FamInst { fi_flavor = flavor, fi_branches = FirstBranch br
+ , fi_group = False, fi_axiom = ax })
+ = pprFamFlavor flavor <+> pp_instance <+>
+ (pprFamInstBranchHdr ax br)
where
- ax = fi_axiom famInst
-
-pprFamInstHdr :: FamInst -> SDoc
-pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor})
- = pprTyConSort <+> pp_instance <+> pprHead
- where
- (fam_tc, tys) = coAxiomSplitLHS axiom
-
- -- For *associated* types, say "type T Int = blah"
+ -- For *associated* types, say "type T Int = blah"
-- For *top level* type instances, say "type instance T Int = blah"
- pp_instance
- | isTyConAssoc fam_tc = empty
- | otherwise = ptext (sLit "instance")
-
- pprHead = sep [ ifPprDebug (ptext (sLit "forall")
- <+> pprTvBndrs (coAxiomTyVars axiom))
- , pprTypeApp fam_tc tys ]
- pprTyConSort = case flavor of
- SynFamilyInst -> ptext (sLit "type")
- DataFamilyInst tycon
- | isDataTyCon tycon -> ptext (sLit "data")
- | isNewTyCon tycon -> ptext (sLit "newtype")
- | isAbstractTyCon tycon -> ptext (sLit "data")
- | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon
-
-pprFamInsts :: [FamInst] -> SDoc
+ pp_instance
+ | isTyConAssoc (famInstTyCon fi) = empty
+ | otherwise = ptext (sLit "instance")
+
+pprFamInst _ = panic "pprFamInst"
+
+pprFamFlavor :: FamFlavor -> SDoc
+pprFamFlavor flavor
+ = case flavor of
+ SynFamilyInst -> ptext (sLit "type")
+ DataFamilyInst tycon
+ | isDataTyCon tycon -> ptext (sLit "data")
+ | isNewTyCon tycon -> ptext (sLit "newtype")
+ | isAbstractTyCon tycon -> ptext (sLit "data")
+ | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon
+
+pprFamInstBranchHdr :: CoAxiom br -> FamInstBranch -> SDoc
+pprFamInstBranchHdr ax (FamInstBranch { fib_lhs = tys, fib_loc = loc })
+ = hang (pprTypeApp fam_tc tys)
+ 2 (ptext (sLit "-- Defined") <+> ppr_loc)
+ where
+ fam_tc = coAxiomTyCon ax
+ ppr_loc
+ | isGoodSrcSpan loc
+ = ptext (sLit "at") <+> ppr (srcSpanStart loc)
+
+ | otherwise
+ = ptext (sLit "in") <+>
+ quotes (ppr (nameModule (coAxiomName ax)))
+
+pprFamInstBranch :: TyCon -> FamInstBranch -> SDoc
+pprFamInstBranch fam_tc (FamInstBranch { fib_lhs = lhs
+ , fib_rhs = rhs })
+ = pprTypeApp fam_tc lhs <+> equals <+> (ppr rhs)
+
+pprFamInsts :: [FamInst br] -> SDoc
pprFamInsts finsts = vcat (map pprFamInst finsts)
+pprFamInstBranches :: TyCon -> [FamInstBranch] -> SDoc
+pprFamInstBranches tc branches = vcat (map (pprFamInstBranch tc) branches)
+
+-- | Create a branch of a @type@ family instance.
+-- This branch must be incorporated into a full @FamInst@ with
+-- @mkSynFamInst@ to be useful.
+mkSynFamInstBranch :: SrcSpan -- ^ where the branch equation appears
+ -> [TyVar] -- ^ bound variables
+ -> [Type] -- ^ LHS type patterns
+ -> Type -- ^ RHS type
+ -> (FamInstBranch, CoAxBranch)
+mkSynFamInstBranch loc tvs lhs_tys rhs_ty
+ = ( FamInstBranch { fib_loc = loc
+ , fib_tvs = mkVarSet tvs
+ , fib_lhs = lhs_tys
+ , fib_rhs = rhs_ty
+ , fib_tcs = mb_tcs }
+ , CoAxBranch { cab_tvs = tvs
+ , cab_lhs = lhs_tys
+ , cab_rhs = rhs_ty })
+ where
+ mb_tcs = roughMatchTcs lhs_tys
+
-- | Create a coercion identifying a @type@ family instance.
-- It has the form @Co tvs :: F ts ~ R@, where @Co@ is
-- the coercion constructor built here, @F@ the family tycon and @R@ the
-- right-hand side of the type family instance.
-mkSynFamInst :: Name -- ^ Unique name for the coercion tycon
- -> [TyVar] -- ^ Type parameters of the coercion (@tvs@)
- -> TyCon -- ^ Family tycon (@F@)
- -> [Type] -- ^ Type instance (@ts@)
- -> Type -- ^ Representation tycon (@R@)
- -> FamInst
-mkSynFamInst name tvs fam_tc inst_tys rep_ty
- = FamInst { fi_fam = tyConName fam_tc,
- fi_fam_tc = fam_tc,
- fi_tcs = roughMatchTcs inst_tys,
- fi_tvs = mkVarSet tvs,
- fi_tys = inst_tys,
- fi_flavor = SynFamilyInst,
- fi_axiom = axiom }
+mkSynFamInst :: Name -- ^ Unique name for the coercion tycon
+ -> TyCon -- ^ Family tycon (@F@)
+ -> Bool -- ^ Was this declared as a branched group?
+ -> [(FamInstBranch, CoAxBranch)] -- ^ the branches of this FamInst
+ -> FamInst Branched
+mkSynFamInst name fam_tc group branches
+ = ASSERT( length branches >= 1 )
+ FamInst { fi_fam = tyConName fam_tc
+ , fi_flavor = SynFamilyInst
+ , fi_branches = toBranchList $ fst $ unzip branches
+ , fi_group = group
+ , fi_axiom = axiom }
where
axiom = CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
+ , co_ax_tc = fam_tc
, co_ax_implicit = False
- , co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp fam_tc inst_tys
- , co_ax_rhs = rep_ty }
-
+ , co_ax_branches = toBranchList (snd $ unzip branches) }
+
+-- | Create a coercion identifying a @type@ family instance, but with only
+-- one equation (branch).
+mkSingleSynFamInst :: Name -- ^ Unique name for the coercion tycon
+ -> [TyVar] -- ^ Type parameters of the coercion (@tvs@)
+ -> TyCon -- ^ Family tycon (@F@)
+ -> [Type] -- ^ Type instance (@ts@)
+ -> Type -- ^ right-hand side
+ -> FamInst Unbranched
+-- See note [Branched axioms] in CoAxiom.lhs
+mkSingleSynFamInst name tvs fam_tc inst_tys rep_ty
+ = FamInst { fi_fam = tyConName fam_tc
+ , fi_flavor = SynFamilyInst
+ , fi_branches = FirstBranch branch
+ , fi_group = False
+ , fi_axiom = axiom }
+ where
+ -- See note [FamInst Locations]
+ branch = FamInstBranch { fib_loc = getSrcSpan name
+ , fib_tvs = mkVarSet tvs
+ , fib_lhs = inst_tys
+ , fib_rhs = rep_ty
+ , fib_tcs = roughMatchTcs inst_tys }
+ axiom = CoAxiom { co_ax_unique = nameUnique name
+ , co_ax_name = name
+ , co_ax_tc = fam_tc
+ , co_ax_implicit = False
+ , co_ax_branches = FirstBranch axBranch }
+ axBranch = CoAxBranch { cab_tvs = tvs
+ , cab_lhs = inst_tys
+ , cab_rhs = rep_ty }
+
-- | Create a coercion identifying a @data@ or @newtype@ representation type
-- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@,
-- where @Co@ is the coercion constructor built here, @F@ the family tycon
@@ -197,50 +345,95 @@ mkDataFamInst :: Name -- ^ Unique name for the coercion tycon
-> TyCon -- ^ Family tycon (@F@)
-> [Type] -- ^ Type instance (@ts@)
-> TyCon -- ^ Representation tycon (@R@)
- -> FamInst
+ -> FamInst Unbranched
mkDataFamInst name tvs fam_tc inst_tys rep_tc
- = FamInst { fi_fam = tyConName fam_tc,
- fi_fam_tc = fam_tc,
- fi_tcs = roughMatchTcs inst_tys,
- fi_tvs = mkVarSet tvs,
- fi_tys = inst_tys,
- fi_flavor = DataFamilyInst rep_tc,
- fi_axiom = axiom }
+ = FamInst { fi_fam = tyConName fam_tc
+ , fi_flavor = DataFamilyInst rep_tc
+ , fi_group = False
+ , fi_branches = FirstBranch branch
+ , fi_axiom = axiom }
where
+ rhs = mkTyConApp rep_tc (mkTyVarTys tvs)
+
+ branch = FamInstBranch { fib_loc = getSrcSpan name
+ -- See Note [FamInst locations]
+ , fib_tvs = mkVarSet tvs
+ , fib_lhs = inst_tys
+ , fib_rhs = rhs
+ , fib_tcs = roughMatchTcs inst_tys }
+
axiom = CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
- , co_ax_implicit = False
- , co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp fam_tc inst_tys
- , co_ax_rhs = mkTyConApp rep_tc (mkTyVarTys tvs) }
+ , co_ax_tc = fam_tc
+ , co_ax_branches = FirstBranch axBranch
+ , co_ax_implicit = False }
+
+ axBranch = CoAxBranch { cab_tvs = tvs
+ , cab_lhs = inst_tys
+ , cab_rhs = rhs }
+
+\end{code}
+
+Note [Lazy axiom match]
+~~~~~~~~~~~~~~~~~~~~~~~
+It is Vitally Important that mkImportedFamInst is *lazy* in its axiom
+parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime
+later, mkImportedFamInst is called using that axiom. However, the axiom
+may itself depend on entities which are not yet loaded as of the time
+of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the
+axiom, a dependency loop spontaneously appears and GHC hangs. The solution
+is simply for mkImportedFamInst never, ever to look inside of the axiom
+until everything else is good and ready to do so. We can assume that this
+readiness has been achieved when some other code pulls on the axiom in the
+FamInst. Thus, we pattern match on the axiom lazily (in the where clause,
+not in the parameter list) and we assert the consistency of names there
+also.
+
+\begin{code}
-- Make a family instance representation from the information found in an
-- interface file. In particular, we get the rough match info from the iface
-- (instead of computing it here).
mkImportedFamInst :: Name -- Name of the family
- -> [Maybe Name] -- Rough match info
- -> CoAxiom -- Axiom introduced
- -> FamInst -- Resulting family instance
-mkImportedFamInst fam mb_tcs axiom
+ -> Bool -- is this a group?
+ -> [[Maybe Name]] -- Rough match info, per branch
+ -> CoAxiom Branched -- Axiom introduced
+ -> FamInst Branched -- Resulting family instance
+mkImportedFamInst fam group roughs axiom
= FamInst {
- fi_fam = fam,
- fi_fam_tc = fam_tc,
- fi_tcs = mb_tcs,
- fi_tvs = mkVarSet . coAxiomTyVars $ axiom,
- fi_tys = tys,
- fi_axiom = axiom,
- fi_flavor = flavor }
+ fi_fam = fam,
+ fi_axiom = axiom,
+ fi_flavor = flavor,
+ fi_group = group,
+ fi_branches = branches }
where
- (fam_tc, tys) = coAxiomSplitLHS axiom
+ -- Lazy match (See note [Lazy axiom match])
+ CoAxiom { co_ax_branches = axBranches }
+ = ASSERT( fam == tyConName (coAxiomTyCon axiom) )
+ axiom
+
+ branches = toBranchList (zipWith mk_fam_inst_branch (fromBranchList axBranches) roughs)
+
+ mk_fam_inst_branch (CoAxBranch { cab_tvs = tvs
+ , cab_lhs = lhs
+ , cab_rhs = rhs }) mb_tcs
+ = FamInstBranch { fib_loc = noSrcSpan
+ , fib_tvs = mkVarSet tvs
+ , fib_lhs = lhs
+ , fib_rhs = rhs
+ , fib_tcs = mb_tcs }
-- Derive the flavor for an imported FamInst rather disgustingly
-- Maybe we should store it in the IfaceFamInst?
- flavor = case splitTyConApp_maybe (coAxiomRHS axiom) of
- Just (tc, _)
- | Just ax' <- tyConFamilyCoercion_maybe tc
- , ax' == axiom
- -> DataFamilyInst tc
- _ -> SynFamilyInst
+ flavor
+ | FirstBranch (CoAxBranch { cab_rhs = rhs }) <- axBranches
+ , Just (tc, _) <- splitTyConApp_maybe rhs
+ , Just ax' <- tyConFamilyCoercion_maybe tc
+ , (toBranchedAxiom ax') == axiom
+ = DataFamilyInst tc
+
+ | otherwise
+ = SynFamilyInst
\end{code}
@@ -278,10 +471,10 @@ type FamInstEnvs = (FamInstEnv, FamInstEnv)
-- External package inst-env, Home-package inst-env
data FamilyInstEnv
- = FamIE [FamInst] -- The instances for a particular family, in any order
- Bool -- True <=> there is an instance of form T a b c
- -- If *not* then the common case of looking up
- -- (T a b c) can fail immediately
+ = FamIE [FamInst Branched] -- The instances for a particular family, in any order
+ Bool -- True <=> there is an instance of form T a b c
+ -- If *not* then the common case of looking up
+ -- (T a b c) can fail immediately
instance Outputable FamilyInstEnv where
ppr (FamIE fs b) = ptext (sLit "FamIE") <+> ppr b <+> vcat (map ppr fs)
@@ -296,10 +489,10 @@ emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)
emptyFamInstEnv :: FamInstEnv
emptyFamInstEnv = emptyUFM
-famInstEnvElts :: FamInstEnv -> [FamInst]
+famInstEnvElts :: FamInstEnv -> [FamInst Branched]
famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
-familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
+familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst Branched]
familyInstances (pkg_fie, home_fie) fam
= get home_fie ++ get pkg_fie
where
@@ -307,18 +500,19 @@ familyInstances (pkg_fie, home_fie) fam
Just (FamIE insts _) -> insts
Nothing -> []
-extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
+extendFamInstEnvList :: FamInstEnv -> [FamInst br] -> FamInstEnv
extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
-extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
-extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
- = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
+extendFamInstEnv :: FamInstEnv -> FamInst br -> FamInstEnv
+extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm})
+ = addToUFM_C add inst_env cls_nm (FamIE [ins_item_br] ins_tyvar)
where
- add (FamIE items tyvar) _ = FamIE (ins_item:items)
+ ins_item_br = toBranchedFamInst ins_item
+ add (FamIE items tyvar) _ = FamIE (ins_item_br:items)
(ins_tyvar || tyvar)
- ins_tyvar = not (any isJust mb_tcs)
+ ins_tyvar = famInstMatchesAny ins_item
-deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
+deleteFromFamInstEnv :: FamInstEnv -> FamInst br -> FamInstEnv
deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm})
= adjustUFM adjust inst_env fam_nm
where
@@ -326,18 +520,27 @@ deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm})
adjust (FamIE items tyvars)
= FamIE (filterOut (identicalFamInst fam_inst) items) tyvars
-identicalFamInst :: FamInst -> FamInst -> Bool
+identicalFamInst :: FamInst br1 -> FamInst br2 -> Bool
-- Same LHS, *and* the instance is defined in the same module
-- Used for overriding in GHCi
identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 })
= nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2)
- && eqTypeX rn_env (coAxiomLHS ax1) (coAxiomLHS ax2)
- where
- tvs1 = coAxiomTyVars ax1
- tvs2 = coAxiomTyVars ax2
- rn_env = ASSERT( equalLength tvs1 tvs2 )
- rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2
-
+ && coAxiomTyCon ax1 == coAxiomTyCon ax2
+ && brListLength brs1 == brListLength brs2
+ && and (brListZipWith identical_ax_branch brs1 brs2)
+ where brs1 = coAxiomBranches ax1
+ brs2 = coAxiomBranches ax2
+ identical_ax_branch br1 br2
+ = length tvs1 == length tvs2
+ && length lhs1 == length lhs2
+ && and (zipWith (eqTypeX rn_env) lhs1 lhs2)
+ where
+ tvs1 = coAxBranchTyVars br1
+ tvs2 = coAxBranchTyVars br2
+ lhs1 = coAxBranchLHS br1
+ lhs2 = coAxBranchLHS br2
+ rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2
+
\end{code}
%************************************************************************
@@ -363,9 +566,93 @@ desugared to
we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
+Note [Instance checking within groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider the following:
+
+type instance where
+ F Int = Bool
+ F a = Int
+
+g :: Show a => a -> F a
+g x = length (show x)
+
+Should that type-check? No. We need to allow for the possibility
+that 'a' might be Int and therefore 'F a' should be Bool. We can
+simplify 'F a' to Int only when we can be sure that 'a' is not Int.
+
+To achieve this, after finding a possible match within an instance group, we
+have to go back to all previous FamInstBranchess and check that, under the
+substitution induced by the match, other matches are not possible. This is
+similar to what happens with class instance selection, when we need to
+guarantee that there is only a match and no unifiers. The exact algorithm is
+different here because the the potentially-overlapping group is closed.
+
+ALTERNATE APPROACH: As we are processing the branches, we could check if an
+instance unifies but does not match. If this happens, there is no possible
+match and we can fail right away. This might be more efficient.
+
+Note [Early failure optimisation for instance groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As we're searching through the instances for a match, it is
+possible that we find an branch within an instance that matches, but
+a previous branch still unifies. In this case, we can abort the
+search, because any other instance that matches will necessarily
+overlap with the instance group we're currently searching. Because
+overlap among instance groups is disallowed, we know that that
+no such other instance exists.
+
+Note [Confluence checking within groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC allows type family instances to have overlapping patterns as long as the
+right-hand sides are coincident in the region of overlap. Can we extend this
+notion of confluent overlap to branched instances? Not in any obvious way.
+
+Consider this:
+
+type instance where
+ F Int = Int
+ F a = a
+
+Without confluence checking (in other words, as implemented), we cannot now
+simplify an application of (F b) -- b might unify with Int later on, so this
+application is stuck. However, it would seem easy to just check that, in the
+region of overlap, (i.e. b |-> Int), the right-hand sides coincide, so we're
+OK. The problem happens when we are simplifying an application (F (G a)),
+where (G a) is stuck. What, now, is the region of overlap? We can't soundly
+simplify (F (G a)) without knowing that the right-hand sides are confluent
+in the region of overlap, but we also can't in any obvious way identify the
+region of overlap. We don't want to do analysis on the instances of G, because
+that is not sound in a world with open type families. (If G were known to be
+closed, there might be a way forward here.) To find the region of overlap,
+it is conceivable that we might convert (G a) to some fresh type variable and
+then unify, but we must be careful to convert every (G a) to the same fresh
+type variable. And then, what if there is an (H a) lying around? It all seems
+rather subtle, error-prone, confusing, and probably won't help anyone. So,
+we're not doing it.
+
+So, why is this not a problem with non-branched confluent overlap? Because
+we don't need to verify that an application is apart from anything. The
+non-branched confluent overlap check happens when we add the instance to the
+environment -- we're unifying among patterns, which cannot contain type family
+appplications. So, we're safe there and can continue supporting that feature.
+
\begin{code}
-type FamInstMatch = (FamInst, [Type]) -- Matching type instance
- -- See Note [Over-saturated matches]
+-- when matching a type family application, we get a FamInst,
+-- a 0-based index of the branch that matched, and the list of types
+-- the axiom should be applied to
+data FamInstMatch = FamInstMatch { fim_instance :: FamInst Branched
+ , fim_index :: Int
+ , fim_tys :: [Type]
+ }
+
+instance Outputable FamInstMatch where
+ ppr (FamInstMatch { fim_instance = inst
+ , fim_index = ind
+ , fim_tys = tys })
+ = ptext (sLit "match with") <+> parens (ppr inst)
+ <> brackets (ppr ind) <+> ppr tys
lookupFamInstEnv
:: FamInstEnvs
@@ -374,94 +661,141 @@ lookupFamInstEnv
-- Precondition: the tycon is saturated (or over-saturated)
lookupFamInstEnv
- = lookup_fam_inst_env match True
- where
- match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
+ = lookup_fam_inst_env match True
+ where
+ match seen (FamInstBranch { fib_tvs = tpl_tvs
+ , fib_lhs = tpl_tys })
+ _ match_tys
+ = ASSERT( tyVarsOfTypes match_tys `disjointVarSet` tpl_tvs )
+ -- Unification will break badly if the variables overlap
+ -- They shouldn't because we allocate separate uniques for them
+ case tcMatchTys tpl_tvs tpl_tys match_tys of
+ -- success
+ Just subst
+ | checkConflict seen match_tys
+ -> (Nothing, StopSearching) -- we found an incoherence, so stop searching
+ -- see Note [Early failure optimisation for instance groups]
+
+ | otherwise
+ -> (Just subst, KeepSearching)
+
+ -- failure; instance not relevant
+ Nothing -> (Nothing, KeepSearching)
+
+ -- see Note [Instance checking within groups]
+ checkConflict :: [FamInstBranch] -- the previous branches in the instance that matched
+ -> [Type] -- the types in the tyfam application we are matching
+ -> Bool -- is there a conflict?
+ checkConflict [] _ = False
+ checkConflict ((FamInstBranch { fib_lhs = tpl_tys }) : rest) match_tys
+ -- see Note [Confluence checking within groups]
+ | SurelyApart <- tcApartTys instanceBindFun tpl_tys match_tys
+ = checkConflict rest match_tys
+ | otherwise
+ = True
lookupFamInstEnvConflicts
:: FamInstEnvs
- -> FamInst -- Putative new instance
- -> [TyVar] -- Unique tyvars, matching arity of FamInst
- -> [FamInstMatch] -- Conflicting matches
+ -> Bool -- True <=> we are checking part of a group with other branches
+ -> TyCon -- The TyCon of the family
+ -> FamInstBranch -- the putative new instance branch
+ -> [FamInstMatch] -- Conflicting branches
-- E.g. when we are about to add
-- f : type instance F [a] = a->a
-- we do (lookupFamInstConflicts f [b])
-- to find conflicting matches
--- The skolem tyvars are needed because we don't have a
--- unique supply to hand
--
-- Precondition: the tycon is saturated (or over-saturated)
-lookupFamInstEnvConflicts envs fam_inst skol_tvs
- = lookup_fam_inst_env my_unify False envs fam tys1
+lookupFamInstEnvConflicts envs grp tc
+ branch@(FamInstBranch { fib_lhs = tys, fib_rhs = rhs })
+ = lookup_fam_inst_env my_unify False envs tc tys
where
- inst_axiom = famInstAxiom fam_inst
- (fam, tys) = famInstLHS fam_inst
- skol_tys = mkTyVarTys skol_tvs
- ax_tvs = coAxiomTyVars inst_axiom
- tys1 = ASSERT2( length ax_tvs == length skol_tys, ppr inst_axiom $$ ppr skol_tys )
- substTys (zipTopTvSubst ax_tvs skol_tys) tys
- -- In example above, fam tys' = F [b]
-
- my_unify old_fam_inst tpl_tvs tpl_tys match_tys
- = ASSERT2( tyVarsOfTypes tys1 `disjointVarSet` tpl_tvs,
- (ppr fam <+> ppr tys1) $$
+ my_unify _ (FamInstBranch { fib_tvs = tpl_tvs, fib_lhs = tpl_tys
+ , fib_rhs = tpl_rhs }) old_grp match_tys
+ = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
+ (pprFamInstBranch tc branch <+> ppr tys) $$
(ppr tpl_tvs <+> ppr tpl_tys) )
-- Unification will break badly if the variables overlap
-- They shouldn't because we allocate separate uniques for them
case tcUnifyTys instanceBindFun tpl_tys match_tys of
- Just subst | conflicting old_fam_inst subst -> Just subst
- _other -> Nothing
-
- -- Note [Family instance overlap conflicts]
- conflicting old_fam_inst subst
- | isAlgTyCon fam = True
- | otherwise = not (old_rhs `eqType` new_rhs)
- where
- old_axiom = famInstAxiom old_fam_inst
- old_tvs = coAxiomTyVars old_axiom
- old_rhs = mkAxInstRHS old_axiom (substTyVars subst old_tvs)
- new_rhs = mkAxInstRHS inst_axiom (substTyVars subst skol_tvs)
+ Just subst
+ | isDataFamilyTyCon tc
+ || grp
+ || old_grp
+ || rhs_conflict tpl_rhs rhs subst
+ -> (Just subst, KeepSearching)
+ | otherwise -- confluent overlap
+ -> (Nothing, KeepSearching)
+ -- irrelevant instance
+ Nothing -> (Nothing, KeepSearching)
+
+ -- checks whether two RHSs are distinct, under a unifying substitution
+ -- Note [Family instance overlap conflicts]
+ rhs_conflict :: Type -> Type -> TvSubst -> Bool
+ rhs_conflict rhs1 rhs2 subst
+ = not (rhs1' `eqType` rhs2')
+ where
+ rhs1' = substTy subst rhs1
+ rhs2' = substTy subst rhs2
-- This variant is called when we want to check if the conflict is only in the
-- home environment (see FamInst.addLocalFamInst)
-lookupFamInstEnvConflicts' :: FamInstEnv -> FamInst -> [TyVar] -> [FamInstMatch]
-lookupFamInstEnvConflicts' env fam_inst skol_tvs
- = lookupFamInstEnvConflicts (emptyFamInstEnv, env) fam_inst skol_tvs
+lookupFamInstEnvConflicts' :: FamInstEnv -> Bool -> TyCon
+ -> FamInstBranch -> [FamInstMatch]
+lookupFamInstEnvConflicts' env
+ = lookupFamInstEnvConflicts (emptyFamInstEnv, env)
\end{code}
+Note [lookup_fam_inst_env' implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To reduce code duplication, both lookups during simplification and conflict
+checking are routed through lookup_fam_inst_env', which looks for a
+matching/unifying branch compared to some target. In the simplification
+case, the search is for a match for a target application; in the conflict-
+checking case, the search is for a unifier for a putative new instance branch.
+
+The two uses are differentiated by different MatchFuns, which look at a given
+branch to see if it is relevant and whether the search should continue. The
+the branch is relevant (i.e. matches or unifies), Just subst is
+returned; if the instance is not relevant, Nothing is returned. The MatchFun
+also indicates what the search algorithm should do next: it could
+KeepSearching or StopSearching.
+
+When to StopSearching? See Note [Early failure optimisation for instance groups]
+
+For class instances, these two variants of lookup are combined into one
+function (cf, @InstEnv@). We don't do that for family instances as the
+results of matching and unification are used in two different contexts.
+Moreover, matching is the wildly more frequently used operation in the case of
+indexed synonyms and we don't want to slow that down by needless unification.
+
Note [Family instance overlap conflicts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- In the case of data family instances, any overlap is fundamentally a
conflict (as these instances imply injective type mappings).
- In the case of type family instances, overlap is admitted as long as
- the right-hand sides of the overlapping rules coincide under the
- overlap substitution. eg
+ the neither instance declares an instance group and the right-hand
+ sides of the overlapping rules coincide under the overlap substitution.
+ For example:
type instance F a Int = a
type instance F Int b = b
These two overlap on (F Int Int) but then both RHSs are Int,
so all is well. We require that they are syntactically equal;
anything else would be difficult to test for at this stage.
-
-While @lookupFamInstEnv@ uses a one-way match, the next function
-@lookupFamInstEnvConflicts@ uses two-way matching (ie, unification). This is
-needed to check for overlapping instances.
-
-For class instances, these two variants of lookup are combined into one
-function (cf, @InstEnv@). We don't do that for family instances as the
-results of matching and unification are used in two different contexts.
-Moreover, matching is the wildly more frequently used operation in the case of
-indexed synonyms and we don't want to slow that down by needless unification.
-
\begin{code}
------------------------------------------------------------
+data ContSearch = KeepSearching
+ | StopSearching
+
-- Might be a one-way match or a unifier
-type MatchFun = FamInst -- The FamInst template
- -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst
- -> [Type] -- Target to match against
- -> Maybe TvSubst
+type MatchFun = [FamInstBranch] -- the previous branches in the instance
+ -> FamInstBranch -- the individual branch to check
+ -> Bool -- is this branch a part of a group?
+ -> [Type] -- the types to match against
+ -> (Maybe TvSubst, ContSearch)
type OneSidedMatch = Bool -- Are optimisations that are only valid for
-- one sided matches allowed?
@@ -470,13 +804,14 @@ lookup_fam_inst_env' -- The worker, local to this module
:: MatchFun
-> OneSidedMatch
-> FamInstEnv
- -> TyCon -> [Type] -- What we are looking for
- -> [FamInstMatch] -- Successful matches
+ -> TyCon -> [Type] -- What we are looking for
+ -> [FamInstMatch]
lookup_fam_inst_env' match_fun one_sided ie fam tys
| not (isFamilyTyCon fam)
= []
| otherwise
- = ASSERT2( n_tys >= arity, ppr fam <+> ppr tys ) -- Family type applications must be saturated
+ -- Family type applications must be saturated
+ = ASSERT2( n_tys >= arity, ppr fam <+> ppr tys )
lookup ie
where
-- See Note [Over-saturated matches]
@@ -504,32 +839,46 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys
| otherwise -> find insts
--------------
+ find :: [FamInst Branched] -> [FamInstMatch]
find [] = []
- find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
- fi_tys = tpl_tys, fi_axiom = axiom }) : rest)
- -- Fast check for no match, uses the "rough match" fields
+ find (inst@(FamInst { fi_branches = branches }) : rest)
+ = case findBranch [] (fromBranchList branches) inst 0 of
+ (Just match, StopSearching) -> [match]
+ (Just match, KeepSearching) -> match : find rest
+ (Nothing, StopSearching) -> []
+ (Nothing, KeepSearching) -> find rest
+
+ findBranch :: [FamInstBranch] -- the branches that have already been checked
+ -> [FamInstBranch] -- still looking through these
+ -> FamInst Branched -- the instance we're looking through
+ -> Int -- the index of the next branch
+ -> (Maybe FamInstMatch, ContSearch)
+ findBranch _ [] _ _ = (Nothing, KeepSearching)
+ findBranch seen (branch@(FamInstBranch { fib_tcs = mb_tcs }) : rest)
+ inst@(FamInst { fi_axiom = axiom, fi_group = group }) ind
| instanceCantMatch rough_tcs mb_tcs
- = find rest
-
- -- Proper check
- | Just subst <- match_fun item tpl_tvs tpl_tys match_tys
- = (item, add_extra_tys $ substTyVars subst (coAxiomTyVars axiom)) : find rest
-
- -- No match => try next
+ = findBranch seen rest inst (ind+1) -- branch won't unify later; ignore
| otherwise
- = find rest
--- Precondition: the tycon is saturated (or over-saturated)
+ = case match_fun seen branch group match_tys of
+ (Nothing, KeepSearching) -> findBranch (branch : seen) rest inst (ind+1)
+ (Nothing, StopSearching) -> (Nothing, StopSearching)
+ (Just subst, cont) -> (Just match, cont)
+ where match = FamInstMatch { fim_instance = inst
+ , fim_index = ind
+ , fim_tys = tys }
+ axBranch = coAxiomNthBranch axiom ind
+ tys = add_extra_tys $
+ substTyVars subst (coAxBranchTyVars axBranch)
lookup_fam_inst_env -- The worker, local to this module
:: MatchFun
-> OneSidedMatch
-> FamInstEnvs
-> TyCon -> [Type] -- What we are looking for
- -> [FamInstMatch] -- Successful matches
+ -> [FamInstMatch] -- What was found
-- Precondition: the tycon is saturated (or over-saturated)
-
-lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys =
+lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys =
lookup_fam_inst_env' match_fun one_sided home_ie fam tys ++
lookup_fam_inst_env' match_fun one_sided pkg_ie fam tys
@@ -550,7 +899,24 @@ Then looking up (F (Int,Bool) Char) will return a FamInstMatch
The "extra" type argument [Char] just stays on the end.
+\begin{code}
+
+-- checks if one LHS is dominated by a list of other branches
+-- in other words, if an application would match the first LHS, it is guaranteed
+-- to match at least one of the others. The RHSs are ignored.
+-- This algorithm is conservative:
+-- True -> the LHS is definitely covered by the others
+-- False -> no information
+-- It is currently (Oct 2012) used only for generating errors for
+-- inaccessible branches. If these errors go unreported, no harm done.
+isDominatedBy :: [Type] -> [FamInstBranch] -> Bool
+isDominatedBy lhs branches
+ = or $ map match branches
+ where
+ match (FamInstBranch { fib_tvs = tvs, fib_lhs = tys })
+ = isJust $ tcMatchTys tvs tys lhs
+\end{code}
%************************************************************************
@@ -586,7 +952,7 @@ topNormaliseType env ty
| isNewTyCon tc -- Expand newtypes
= if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs
then Nothing
- else let nt_co = mkAxInstCo (newTyConCo tc) tys
+ else let nt_co = mkUnbranchedAxInstCo (newTyConCo tc) tys
in add_co nt_co rec_nts' nt_rhs
| isFamilyTyCon tc -- Expand open tycons
@@ -615,15 +981,17 @@ normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type)
normaliseTcApp env tc tys
| isFamilyTyCon tc
, tyConArity tc <= length tys -- Unsaturated data families are possible
- , [(fam_inst, inst_tys)] <- lookupFamInstEnv env tc ntys
+ , [FamInstMatch { fim_instance = fam_inst
+ , fim_index = fam_ind
+ , fim_tys = inst_tys }] <- lookupFamInstEnv env tc ntys
= let -- A matching family instance exists
ax = famInstAxiom fam_inst
- co = mkAxInstCo ax inst_tys
- rhs = mkAxInstRHS ax inst_tys
+ co = mkAxInstCo ax fam_ind inst_tys
+ rhs = mkAxInstRHS ax fam_ind inst_tys
first_coi = mkTransCo tycon_coi co
(rest_coi,nty) = normaliseType env rhs
fix_coi = mkTransCo first_coi rest_coi
- in
+ in
(fix_coi, nty)
| otherwise -- No unique matching family instance exists;
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index a039fe5b3f94f2d26e078d059b6d5b97561d5cb7..b16e1aae5f0aa5413b05842af4193877ec41bbf7 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -18,6 +18,7 @@ import Coercion
import Type hiding( substTyVarBndr, substTy, extendTvSubst )
import TcType ( exactTyVarsOfType )
import TyCon
+import CoAxiom
import Var
import VarSet
import VarEnv
@@ -119,12 +120,12 @@ opt_co' env sym (CoVarCo cv)
ASSERT( isCoVar cv )
wrapSym sym (CoVarCo cv)
-opt_co' env sym (AxiomInstCo con cos)
+opt_co' env sym (AxiomInstCo con ind cos)
-- Do *not* push sym inside top-level axioms
-- e.g. if g is a top-level axiom
-- g a : f a ~ a
-- then (sym (g ty)) /= g (sym ty) !!
- = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos)
+ = wrapSym sym $ AxiomInstCo con ind (map (opt_co env False) cos)
-- Note that the_co does *not* have sym pushed into it
opt_co' env sym (UnsafeCo ty1 ty2)
@@ -288,29 +289,31 @@ opt_trans_rule is co1 co2
opt_trans_rule is co1 co2
-- TrPushAxR/TrPushSymAxR
- | Just (sym, con, cos1) <- co1_is_axiom_maybe
- , Just cos2 <- matchAxiom sym con co2
+ | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
+ , Just cos2 <- matchAxiom sym con ind co2
= fireTransRule "TrPushAxR" co1 co2 $
if sym
- then SymCo $ AxiomInstCo con (opt_transList is (map mkSymCo cos2) cos1)
- else AxiomInstCo con (opt_transList is cos1 cos2)
+ then SymCo $ AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)
+ else AxiomInstCo con ind (opt_transList is cos1 cos2)
-- TrPushAxL/TrPushSymAxL
- | Just (sym, con, cos2) <- co2_is_axiom_maybe
- , Just cos1 <- matchAxiom (not sym) con co1
+ | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
+ , Just cos1 <- matchAxiom (not sym) con ind co1
= fireTransRule "TrPushAxL" co1 co2 $
if sym
- then SymCo $ AxiomInstCo con (opt_transList is cos2 (map mkSymCo cos1))
- else AxiomInstCo con (opt_transList is cos1 cos2)
+ then SymCo $ AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))
+ else AxiomInstCo con ind (opt_transList is cos1 cos2)
-- TrPushAxSym/TrPushSymAx
- | Just (sym1, con1, cos1) <- co1_is_axiom_maybe
- , Just (sym2, con2, cos2) <- co2_is_axiom_maybe
+ | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
+ , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
, con1 == con2
+ , ind1 == ind2
, sym1 == not sym2
- , let qtvs = co_ax_tvs con1
- lhs = co_ax_lhs con1
- rhs = co_ax_rhs con1
+ , let branch = coAxiomNthBranch con1 ind1
+ qtvs = coAxBranchTyVars branch
+ lhs = coAxNthLHS con1 ind1
+ rhs = coAxBranchRHS branch
pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs)
, all (`elemVarSet` pivot_tvs) qtvs
= fireTransRule "TrPushAxSym" co1 co2 $
@@ -341,20 +344,23 @@ wrapSym sym co | sym = SymCo co
| otherwise = co
-----------
-isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion])
+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])
isAxiom_maybe (SymCo co)
- | Just (sym, con, cos) <- isAxiom_maybe co
- = Just (not sym, con, cos)
-isAxiom_maybe (AxiomInstCo con cos)
- = Just (False, con, cos)
+ | Just (sym, con, ind, cos) <- isAxiom_maybe co
+ = Just (not sym, con, ind, cos)
+isAxiom_maybe (AxiomInstCo con ind cos)
+ = Just (False, con, ind, cos)
isAxiom_maybe _ = Nothing
matchAxiom :: Bool -- True = match LHS, False = match RHS
- -> CoAxiom -> Coercion -> Maybe [Coercion]
+ -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]
-- If we succeed in matching, then *all the quantified type variables are bound*
-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail
-matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co
- = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of
+matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co
+ = let (CoAxBranch { cab_tvs = qtvs
+ , cab_lhs = lhs
+ , cab_rhs = rhs }) = coAxiomNthBranch ax ind in
+ case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of
Nothing -> Nothing
Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 458f5c6e208a8f14a910821d099e398cf1b8db9c..5286617db83b4025fa1adc1c7bd8d059cd85b064 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -6,6 +6,7 @@
The @TyCon@ datatype
\begin{code}
+
module TyCon(
-- * Main TyCon data types
TyCon, FieldLabel,
@@ -14,11 +15,6 @@ module TyCon(
TyConParent(..), isNoParent,
SynTyConRhs(..),
- -- ** Coercion axiom constructors
- CoAxiom(..),
- coAxiomName, coAxiomArity, coAxiomTyVars,
- coAxiomLHS, coAxiomRHS, isImplicitCoAxiom,
-
-- ** Constructing TyCons
mkAlgTyCon,
mkClassTyCon,
@@ -96,6 +92,7 @@ import BasicTypes
import DynFlags
import ForeignCall
import Name
+import CoAxiom
import PrelNames
import Maybes
import Outputable
@@ -475,7 +472,8 @@ data AlgTyConRhs
-- shorter than the declared arity of the 'TyCon'.
-- See Note [Newtype eta]
- nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from
+ nt_co :: CoAxiom Unbranched
+ -- The axiom coercion that creates the @newtype@ from
-- the representation 'Type'.
-- See Note [Newtype coercions]
@@ -531,11 +529,11 @@ data TyConParent
-- 3) A 'CoTyCon' identifying the representation
-- type with the type instance family
| FamInstTyCon -- See Note [Data type families]
- CoAxiom -- The coercion constructor,
- -- always of kind T ty1 ty2 ~ R:T a b c
- -- where T is the family TyCon,
- -- and R:T is the representation TyCon (ie this one)
- -- and a,b,c are the tyConTyVars of this TyCon
+ (CoAxiom Unbranched) -- The coercion constructor,
+ -- always of kind T ty1 ty2 ~ R:T a b c
+ -- where T is the family TyCon,
+ -- and R:T is the representation TyCon (ie this one)
+ -- and a,b,c are the tyConTyVars of this TyCon
-- Cached fields of the CoAxiom, but adjusted to
-- use the tyConTyVars of this TyCon
@@ -704,59 +702,6 @@ so the coercion tycon CoT must have
kind: T ~ []
and arity: 0
-
-%************************************************************************
-%* *
- Coercion axioms
-%* *
-%************************************************************************
-
-\begin{code}
--- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
-
--- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
-data CoAxiom
- = CoAxiom -- Type equality axiom.
- { co_ax_unique :: Unique -- unique identifier
- , co_ax_name :: Name -- name for pretty-printing
- , co_ax_tvs :: [TyVar] -- bound type variables
- , co_ax_lhs :: Type -- left-hand side of the equality
- , co_ax_rhs :: Type -- right-hand side of the equality
- , co_ax_implicit :: Bool -- True <=> the axiom is "implicit"
- -- See Note [Implicit axioms]
- }
- deriving Typeable
-
-coAxiomArity :: CoAxiom -> Arity
-coAxiomArity ax = length (co_ax_tvs ax)
-
-coAxiomName :: CoAxiom -> Name
-coAxiomName = co_ax_name
-
-coAxiomTyVars :: CoAxiom -> [TyVar]
-coAxiomTyVars = co_ax_tvs
-
-coAxiomLHS, coAxiomRHS :: CoAxiom -> Type
-coAxiomLHS = co_ax_lhs
-coAxiomRHS = co_ax_rhs
-
-isImplicitCoAxiom :: CoAxiom -> Bool
-isImplicitCoAxiom = co_ax_implicit
-\end{code}
-
-Note [Implicit axioms]
-~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Implicit TyThings] in HscTypes
-* A CoAxiom arising from data/type family instances is not "implicit".
- That is, it has its own IfaceAxiom declaration in an interface file
-
-* The CoAxiom arising from a newtype declaration *is* "implicit".
- That is, it does not have its own IfaceAxiom declaration in an
- interface file; instead the CoAxiom is generated by type-checking
- the newtype declaration
-
-
%************************************************************************
%* *
\subsection{PrimRep}
@@ -1104,7 +1049,7 @@ isNewTyCon _ = False
-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands
-- into, and (possibly) a coercion from the representation type to the @newtype@.
-- Returns @Nothing@ if this is not possible.
-unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom)
+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)
unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
algTcRhs = NewTyCon { nt_co = co,
nt_rhs = rhs }})
@@ -1387,11 +1332,11 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)
-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something
-- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon'
-- is not a @newtype@, returns @Nothing@
-newTyConCo_maybe :: TyCon -> Maybe CoAxiom
+newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)
newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co
newTyConCo_maybe _ = Nothing
-newTyConCo :: TyCon -> CoAxiom
+newTyConCo :: TyCon -> CoAxiom Unbranched
newTyConCo tc = case newTyConCo_maybe tc of
Just co -> co
Nothing -> pprPanic "newTyConCo" (ppr tc)
@@ -1460,14 +1405,13 @@ tyConParent (SynTyCon {synTcParent = parent}) = parent
tyConParent _ = NoParentTyCon
----------------------------------------------------------------------------
--- | Is this 'TyCon' that for a family instance, be that for a synonym or an
--- algebraic family instance?
+-- | Is this 'TyCon' that for a data family instance?
isFamInstTyCon :: TyCon -> Bool
isFamInstTyCon tc = case tyConParent tc of
FamInstTyCon {} -> True
_ -> False
-tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom)
+tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
tyConFamInstSig_maybe tc
= case tyConParent tc of
FamInstTyCon ax f ts -> Just (f, ts, ax)
@@ -1484,7 +1428,7 @@ tyConFamInst_maybe tc
-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents
-- a coercion identifying the representation type with the type instance family.
-- Otherwise, return @Nothing@
-tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom
+tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe tc
= case tyConParent tc of
FamInstTyCon co _ _ -> Just co
@@ -1539,30 +1483,4 @@ instance Data.Data TyCon where
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "TyCon"
--------------------
-instance Eq CoAxiom where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord CoAxiom where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = getUnique a `compare` getUnique b
-
-instance Uniquable CoAxiom where
- getUnique = co_ax_unique
-
-instance Outputable CoAxiom where
- ppr = ppr . getName
-
-instance NamedThing CoAxiom where
- getName = co_ax_name
-
-instance Data.Data CoAxiom where
- -- don't traverse?
- toConstr _ = abstractConstr "CoAxiom"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNoRepType "CoAxiom"
\end{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 0f1a8be542170e1c0bc216b1f0cff66511c6da24..efe8a3bde37604893d3c3f588a0a6e2124502805 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -45,6 +45,8 @@ module Type (
mkNumLitTy, isNumLitTy,
mkStrLitTy, isStrLitTy,
+
+ coAxNthLHS,
-- (Newtypes)
newTyConInstRhs, carefullySplitNewType_maybe,
@@ -155,6 +157,7 @@ import TysPrim
import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeStringKind )
import PrelNames ( eqTyConKey, ipClassNameKey,
constraintKindTyConKey, liftedTypeKindTyConKey )
+import CoAxiom
-- others
import Unique ( Unique, hasKey )
@@ -1041,6 +1044,12 @@ mkFamilyTyConApp tc tys
| otherwise
= mkTyConApp tc tys
+-- | Get the type on the LHS of a coercion induced by a type/data
+-- family instance.
+coAxNthLHS :: CoAxiom br -> Int -> Type
+coAxNthLHS ax ind =
+ mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))
+
-- | Pretty prints a 'TyCon', using the family instance in case of a
-- representation tycon. For example:
--
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 6e481ca5b56b5b26c1ca91e921a2d8f0ea47b965..c8235d414625b1248b2df151cc2aee85add10593 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -64,6 +64,7 @@ import Name
import BasicTypes
import TyCon
import Class
+import CoAxiom
-- others
import PrelNames
@@ -307,7 +308,7 @@ isKindVar v = isTKVar v && isSuperKind (varType v)
%* *
%************************************************************************
-\begin{code}
+\begin{code}
tyVarsOfType :: Type -> VarSet
-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
-- tyVarsOfType returns only the free variables of a type
@@ -349,7 +350,7 @@ data TyThing
= AnId Id
| ADataCon DataCon
| ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes]
- | ACoAxiom CoAxiom
+ | ACoAxiom (CoAxiom Branched)
deriving (Eq, Ord)
instance Outputable TyThing where
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index de4f3fe86552935133d44c2914ec350715d623da..2410a02f37ef10f43b53d3b55956b0883953d4aa 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -23,7 +23,9 @@ module Unify (
-- Side-effect free unification
tcUnifyTys, BindFlag(..),
- niFixTvSubst, niSubstTvSet
+ niFixTvSubst, niSubstTvSet,
+
+ ApartResult(..), tcApartTys
) where
@@ -36,11 +38,7 @@ import Kind
import Type
import TyCon
import TypeRep
-import Outputable
-import ErrUtils
import Util
-import Maybes
-import FastString
\end{code}
@@ -358,7 +356,71 @@ typesCantMatch prs = any (\(s,t) -> cant_match s t) prs
%* *
%************************************************************************
+Note [Unification and apartness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The workhorse function behind unification actually is testing for apartness,
+not unification. Here, two types are apart if it is never possible to unify
+them or any types they are safely coercible to.(* see below) There are three
+possibilities here:
+
+ - two types might be NotApart, which means a substitution can be found between
+ them,
+
+ Example: (Either a Int) and (Either Bool b) are NotApart, with
+ [a |-> Bool, b |-> Int]
+
+ - they might be MaybeApart, which means that we're not sure, but a substitution
+ cannot be found
+
+ Example: Int and F a (for some type family F) are MaybeApart
+
+ - they might be SurelyApart, in which case we can guarantee that they never
+ unify
+
+ Example: (Either Int a) and (Either Bool b) are SurelyApart
+
+In the NotApart case, the apartness finding function also returns a
+substitution, which we can then use to unify the types. It is necessary for
+the unification algorithm to depend on the apartness algorithm, because
+apartness is finer-grained than unification.
+
+Note [Unifying with type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We wish to separate out the case where unification fails on a type family
+from other unification failure. What does "fail on a type family" look like?
+According to the TyConApp invariant, a type family application must always
+be in a TyConApp. This TyConApp may not be buried within the left-hand-side
+of an AppTy.
+
+Furthermore, we wish to proceed with unification if we are unifying
+(F a b) with (F Int Bool). Here, unification should succeed with
+[a |-> Int, b |-> Bool]. So, here is what we do:
+
+ - If we are unifying two TyConApps, check the heads for equality and
+ proceed iff they are equal.
+
+ - Otherwise, if either (or both) type is a TyConApp headed by a type family,
+ we know they cannot fully unify. But, they might unify later, depending
+ on the type family. So, we return "maybeApart".
+
+Note that we never want to unify, say, (a Int) with (F Int), because doing so
+leads to an unsaturated type family. So, we don't have to worry about any
+unification between type families and AppTys.
+
+But wait! There is one more possibility. What about nullary type families?
+If G is a nullary type family, we *do* want to unify (a) with (G). This is
+handled in uVar, which is triggered before we look at TyConApps. Ah. All is
+well again.
+
+Note [Apartness with skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we discover that two types unify if and only if a skolem variable is
+substituted, we can't properly unify the types. But, that skolem variable
+may later be instantiated with a unifyable type. So, we return maybeApart
+in these cases.
+
\begin{code}
+-- See Note [Unification and apartness]
tcUnifyTys :: (TyVar -> BindFlag)
-> [Type] -> [Type]
-> Maybe TvSubst -- A regular one-shot (idempotent) substitution
@@ -366,7 +428,20 @@ tcUnifyTys :: (TyVar -> BindFlag)
-- second call to tcUnifyTys in FunDeps.checkClsFD
--
tcUnifyTys bind_fn tys1 tys2
- = maybeErrToMaybe $ initUM bind_fn $
+ | NotApart subst <- tcApartTys bind_fn tys1 tys2
+ = Just subst
+ | otherwise
+ = Nothing
+
+data ApartResult = NotApart TvSubst -- the subst that unifies the types
+ | MaybeApart
+ | SurelyApart
+
+tcApartTys :: (TyVar -> BindFlag)
+ -> [Type] -> [Type]
+ -> ApartResult
+tcApartTys bind_fn tys1 tys2
+ = initUM bind_fn $
do { subst <- unifyList emptyTvSubstEnv tys1 tys2
-- Find the fixed point of the resulting non-idempotent substitution
@@ -437,7 +512,14 @@ unify subst ty1 ty2 | Just ty1' <- tcView ty1 = unify subst ty1' ty2
unify subst ty1 ty2 | Just ty2' <- tcView ty2 = unify subst ty1 ty2'
unify subst (TyConApp tyc1 tys1) (TyConApp tyc2 tys2)
- | tyc1 == tyc2 = unify_tys subst tys1 tys2
+ | tyc1 == tyc2 = unify_tys subst tys1 tys2
+ | isSynFamilyTyCon tyc1 || isSynFamilyTyCon tyc2 = maybeApart
+
+-- See Note [Unifying with type families]
+unify _ (TyConApp tyc _) _
+ | isSynFamilyTyCon tyc = maybeApart
+unify _ _ (TyConApp tyc _)
+ | isSynFamilyTyCon tyc = maybeApart
unify subst (FunTy ty1a ty1b) (FunTy ty2a ty2b)
= do { subst' <- unify subst ty1a ty2a
@@ -459,7 +541,7 @@ unify subst ty1 (AppTy ty2a ty2b)
unify subst (LitTy x) (LitTy y) | x == y = return subst
-unify _ ty1 ty2 = failWith (misMatch ty1 ty2)
+unify _ _ _ = surelyApart
-- ForAlls??
------------------------------
@@ -473,7 +555,7 @@ unifyList subst orig_xs orig_ys
go subst [] [] = return subst
go subst (x:xs) (y:ys) = do { subst' <- unify subst x y
; go subst' xs ys }
- go _ _ _ = failWith (lengthMisMatch orig_xs orig_ys)
+ go _ _ _ = surelyApart
---------------------------------
uVar :: TvSubstEnv -- An existing substitution to extend
@@ -481,10 +563,6 @@ uVar :: TvSubstEnv -- An existing substitution to extend
-> Type -- with this type
-> UM TvSubstEnv
--- PRE-CONDITION: in the call (uVar swap r tv1 ty), we know that
--- if swap=False (tv1~ty)
--- if swap=True (ty~tv1)
-
uVar subst tv1 ty
= -- Check to see whether tv1 is refined by the substitution
case (lookupVarEnv subst tv1) of
@@ -529,13 +607,13 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2)
; b2 <- tvBindFlag tv2
; let ty1 = TyVarTy tv1
; case (b1, b2) of
- (Skolem, Skolem) -> failWith (misMatch ty1 ty2)
+ (Skolem, Skolem) -> maybeApart -- See Note [Apartness with skolems]
(BindMe, _) -> return (extendVarEnv subst' tv1 ty2)
(_, BindMe) -> return (extendVarEnv subst' tv2 ty1) }
uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable
| tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2')
- = failWith (occursCheck tv1 ty2) -- Occurs check
+ = surelyApart -- Occurs check
| otherwise
= do { subst' <- unify subst k1 k2
; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss
@@ -547,7 +625,7 @@ bindTv :: TvSubstEnv -> TyVar -> Type -> UM TvSubstEnv
bindTv subst tv ty -- ty is not a type variable
= do { b <- tvBindFlag tv
; case b of
- Skolem -> failWith (misMatch (TyVarTy tv) ty)
+ Skolem -> maybeApart -- See Note [Apartness with skolems]
BindMe -> return $ extendVarEnv subst tv ty
}
\end{code}
@@ -574,53 +652,33 @@ data BindFlag
%************************************************************************
\begin{code}
+data UnifFailure = UFMaybeApart
+ | UFSurelyApart
+
newtype UM a = UM { unUM :: (TyVar -> BindFlag)
- -> MaybeErr MsgDoc a }
+ -> Either UnifFailure a }
instance Monad UM where
- return a = UM (\_tvs -> Succeeded a)
- fail s = UM (\_tvs -> Failed (text s))
+ return a = UM (\_tvs -> Right a)
+ fail _ = UM (\_tvs -> Left UFSurelyApart) -- failed pattern match
m >>= k = UM (\tvs -> case unUM m tvs of
- Failed err -> Failed err
- Succeeded v -> unUM (k v) tvs)
-
-initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr MsgDoc a
-initUM badtvs um = unUM um badtvs
-
+ Right v -> unUM (k v) tvs
+ Left f -> Left f)
+
+initUM :: (TyVar -> BindFlag) -> UM TvSubst -> ApartResult
+initUM badtvs um
+ = case unUM um badtvs of
+ Right subst -> NotApart subst
+ Left UFMaybeApart -> MaybeApart
+ Left UFSurelyApart -> SurelyApart
+
tvBindFlag :: TyVar -> UM BindFlag
-tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv))
+tvBindFlag tv = UM (\tv_fn -> Right (tv_fn tv))
-failWith :: MsgDoc -> UM a
-failWith msg = UM (\_tv_fn -> Failed msg)
+maybeApart :: UM a
+maybeApart = UM (\_tv_fn -> Left UFMaybeApart)
-maybeErrToMaybe :: MaybeErr fail succ -> Maybe succ
-maybeErrToMaybe (Succeeded a) = Just a
-maybeErrToMaybe (Failed _) = Nothing
+surelyApart :: UM a
+surelyApart = UM (\_tv_fn -> Left UFSurelyApart)
\end{code}
-
-%************************************************************************
-%* *
- Error reporting
- We go to a lot more trouble to tidy the types
- in TcUnify. Maybe we'll end up having to do that
- here too, but I'll leave it for now.
-%* *
-%************************************************************************
-
-\begin{code}
-misMatch :: Type -> Type -> SDoc
-misMatch t1 t2
- = ptext (sLit "Can't match types") <+> quotes (ppr t1) <+>
- ptext (sLit "and") <+> quotes (ppr t2)
-
-lengthMisMatch :: [Type] -> [Type] -> SDoc
-lengthMisMatch tys1 tys2
- = sep [ptext (sLit "Can't match unequal length lists"),
- nest 2 (ppr tys1), nest 2 (ppr tys2) ]
-
-occursCheck :: TyVar -> Type -> SDoc
-occursCheck tv ty
- = hang (ptext (sLit "Can't construct the infinite type"))
- 2 (ppr tv <+> equals <+> ppr ty)
-\end{code}
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 8b7e817826a130db1464720bc8ab06e743b4ad12..1d71dd7340cc20d5dab7eabdc9fd18e81afa773c 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -30,6 +30,7 @@ import BasicTypes ( isStrongLoopBreaker )
import Outputable
import Util ( zipLazy )
import MonadUtils
+import FamInstEnv ( toBranchedFamInst )
import Control.Monad
import Data.Maybe
@@ -97,7 +98,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 ++ new_fam_insts
+ , mg_fam_insts = fam_insts ++ (map toBranchedFamInst new_fam_insts)
}
}
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index a887e7736f5c8e24bd87140598d1742c5207df3e..b23093e04951c62d5d68fbfc00bc220ecd3cf504 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -184,7 +184,7 @@ extendImportedVarsEnv ps genv
-- |Extend the list of type family instances.
--
-extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv
+extendFamEnv :: [FamInst Unbranched] -> GlobalEnv -> GlobalEnv
extendFamEnv new genv
= genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index da95884326b40c5d8bbf03b4a5619ff8b7fb7846..f70e796daa9339ad45b1fe8f676cf8c15db573e5 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -15,6 +15,7 @@ import CoreUtils
import CoreUnfold
import Module
import TyCon
+import CoAxiom
import Type
import Id
import Var
@@ -47,7 +48,8 @@ import FastString
--
buildPADict
:: TyCon -- ^ tycon of the type being vectorised.
- -> CoAxiom -- ^ Coercion between the type and
+ -> CoAxiom Unbranched
+ -- ^ Coercion between the type and
-- its vectorised representation.
-> TyCon -- ^ PData instance tycon
-> TyCon -- ^ PDatas instance tycon
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index 61c07cd299be13661f1b2ad71cdb7e66b535a492..77880a67406a96e0cbe1030a5ce66844a03c5b4a 100644
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
@@ -18,6 +18,7 @@ import CoreUtils
import FamInstEnv
import MkCore ( mkWildCase )
import TyCon
+import CoAxiom
import Type
import OccName
import Coercion
@@ -30,12 +31,12 @@ import Control.Monad
import Outputable
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
+buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPReprTyCon orig_tc vect_tc repr
= do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
rhs_ty <- sumReprType repr
prepr_tc <- builtin preprTyCon
- return $ mkSynFamInst name tyvars prepr_tc instTys rhs_ty
+ return $ mkSingleSynFamInst name tyvars prepr_tc instTys rhs_ty
where
tyvars = tyConTyVars vect_tc
instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]
@@ -59,7 +60,8 @@ buildPReprTyCon orig_tc vect_tc repr
--
type PAInstanceBuilder
= TyCon -- ^ Vectorised TyCon
- -> CoAxiom -- ^ Coercion to the representation TyCon
+ -> CoAxiom Unbranched
+ -- ^ Coercion to the representation TyCon
-> TyCon -- ^ 'PData' TyCon
-> TyCon -- ^ 'PDatas' TyCon
-> SumRepr -- ^ Description of generic representation.
@@ -95,7 +97,7 @@ buildToPRepr vect_tc repr_ax _ _ repr
where
ty_args = mkTyVarTys (tyConTyVars vect_tc)
- wrap_repr_inst = wrapTypeFamInstBody repr_ax ty_args
+ wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args
-- CoreExp to convert the given argument to the generic representation.
-- We start by doing a case branch on the possible data constructors.
@@ -158,7 +160,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr
arg_ty <- mkPReprType res_ty
arg <- newLocalVar (fsLit "x") arg_ty
- result <- from_sum (unwrapTypeFamInstScrut repr_ax ty_args (Var arg))
+ result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args (Var arg))
repr
return $ Lam arg result
where
@@ -214,7 +216,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
. mkSymCo
- $ mkAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
@@ -278,7 +280,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
- $ mkAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo repr_co var_tys
let scrut = mkCast (Var arg) co
@@ -364,7 +366,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
. mkSymCo
- $ mkAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo repr_co ty_args
let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
(vars, result) <- to_sum r
@@ -454,7 +456,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
-- Build the coercion between PRepr and the instance type
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
- $ mkAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo repr_co var_tys
let scrut = mkCast (Var varg) co
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 49997f8502fafd97a995927eb90e3b2f89698bd1..0d3d650a1c9cbee267ca9286d89591e9f76fe9b5 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -27,7 +27,7 @@ import Control.Monad
-- buildPDataTyCon ------------------------------------------------------------
-- | Build the PData instance tycon for a given type constructor.
-buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
+buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPDataTyCon orig_tc vect_tc repr
= fixV $ \fam_inst ->
do let repr_tc = dataFamInstRepTyCon fam_inst
@@ -38,7 +38,7 @@ buildPDataTyCon orig_tc vect_tc repr
where
orig_name = tyConName orig_tc
-buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
+buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranched)
buildDataFamInst name' fam_tc vect_tc rhs
= do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
@@ -85,7 +85,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
-- buildPDatasTyCon -----------------------------------------------------------
-- | Build the PDatas instance tycon for a given type constructor.
-buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
+buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPDatasTyCon orig_tc vect_tc repr
= fixV $ \fam_inst ->
do let repr_tc = dataFamInstRepTyCon fam_inst
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index fc12ee567cdedc14717c225a0dc33652d2d9a15a..0150415de9caa3f54a1c3ea31355702600e37d94 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
@@ -56,12 +56,12 @@ lookupInst cls tys
--
-- which implies that :R42T was declared as 'data instance T [a]'.
--
-lookupFamInst :: TyCon -> [Type] -> VM (FamInst, [Type])
+lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch
lookupFamInst tycon tys
= ASSERT( isFamilyTyCon tycon )
do { instEnv <- readGEnv global_fam_inst_env
; case lookupFamInstEnv instEnv tycon tys of
- [(fam_inst, rep_tys)] -> return ( fam_inst, rep_tys)
+ [match] -> return match
_other ->
do dflags <- getDynFlags
cantVectorise dflags "VectMonad.lookupFamInst: not found: "
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 5dfbaa5555bdf0e6512544d332d0631e03c3a3c9..77aa8c53750daa4bc8f34d5c00609c20d5ec4a09 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -26,6 +26,7 @@ import CoreUtils
import CoreUnfold
import DataCon
import TyCon
+import CoAxiom
import Type
import FamInstEnv
import Id
@@ -139,12 +140,12 @@ import Data.List
-- |Vectorise type constructor including class type constructors.
--
-vectTypeEnv :: [TyCon] -- Type constructors defined in this module
- -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module
- -> [CoreVect] -- All 'VECTORISE class' declarations in this module
- -> VM ( [TyCon] -- old TyCons ++ new TyCons
- , [FamInst] -- New type family instances.
- , [(Var, CoreExpr)]) -- New top level bindings.
+vectTypeEnv :: [TyCon] -- Type constructors defined in this module
+ -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module
+ -> [CoreVect] -- All 'VECTORISE class' declarations in this module
+ -> VM ( [TyCon] -- old TyCons ++ new TyCons
+ , [FamInst Unbranched] -- New type family instances.
+ , [(Var, CoreExpr)]) -- New top level bindings.
vectTypeEnv tycons vectTypeDecls vectClassDecls
= do { traceVt "** vectTypeEnv" $ ppr tycons
@@ -339,7 +340,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
-- Helpers --------------------------------------------------------------------
-buildTyConPADict :: TyCon -> CoAxiom -> TyCon -> TyCon -> VM Var
+buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var
buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc
= tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index a03875f1167798d7be5d9bcbe34d92af06988616..d088f453553e6d0e151f279d1a704573f997e97d 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -39,6 +39,10 @@ import DataCon
import MkId
import DynFlags
import FastString
+import Util
+import Panic
+
+#include "HsVersions.h"
-- Simple Types ---------------------------------------------------------------
@@ -206,8 +210,11 @@ unwrapNewTypeBodyOfPDatasWrap e ty
pdataReprTyCon :: Type -> VM (TyCon, [Type])
pdataReprTyCon ty
= do
- { (famInst, tys) <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
- ; return (dataFamInstRepTyCon famInst, tys)
+ { FamInstMatch { fim_instance = famInst
+ , fim_index = index
+ , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
+ ; ASSERT( index == 0 )
+ return (dataFamInstRepTyCon famInst, tys)
}
-- |Get the representation tycon of the 'PData' data family for a given type constructor.
@@ -231,8 +238,7 @@ pdataReprTyConExact tycon
pdatasReprTyConExact :: TyCon -> VM TyCon
pdatasReprTyConExact tycon
= do { -- look up the representation tycon; if there is a match at all, it will be be exact
- ; -- (i.e.,' _tys' will be distinct type variables)
- ; (ptycon, _tys) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
+ ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
; return $ dataFamInstRepTyCon ptycon
}
where
@@ -254,5 +260,5 @@ pdataUnwrapScrut (ve, le)
-- |Get the representation tycon of the 'PRepr' type family for a given type.
--
-preprSynTyCon :: Type -> VM (FamInst, [Type])
+preprSynTyCon :: Type -> VM FamInstMatch
preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 85060c477c9a4f2ac678e3acd89dfde042d4517d..8029dfb4662ae749b6a12a68ff6f2813d2b9b1c7 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -17,6 +17,7 @@ import Coercion
import Type
import TypeRep
import TyCon
+import CoAxiom
import Var
import Outputable
import DynFlags
@@ -117,8 +118,8 @@ paMethod method _ ty
prDictOfPReprInst :: Type -> VM CoreExpr
prDictOfPReprInst ty
= do
- { (prepr_fam, prepr_args) <- preprSynTyCon ty
- ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args
+ { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty
+ ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args
}
-- |Given a type @ty@, its PRepr synonym tycon and its type arguments,
@@ -136,15 +137,15 @@ prDictOfPReprInst ty
--
-- Note that @ty@ is only used for error messages
--
-prDictOfPReprInstTyCon :: Type -> CoAxiom -> [Type] -> VM CoreExpr
+prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr
prDictOfPReprInstTyCon _ty prepr_ax prepr_args
= do
- let rhs = mkAxInstRHS prepr_ax prepr_args
+ let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args
dict <- prDictOfReprType' rhs
pr_co <- mkBuiltinCo prTyCon
let co = mkAppCo pr_co
$ mkSymCo
- $ mkAxInstCo prepr_ax prepr_args
+ $ mkUnbranchedAxInstCo prepr_ax prepr_args
return $ mkCast dict co
-- |Get the PR dictionary for a type. The argument must be a representation
diff --git a/docs/core-spec/CoreLint.ott b/docs/core-spec/CoreLint.ott
index b142901edea13eb559dcd5409f9dbf6f48edd148..beaf52a7d941b289705ceab1ff07fcc6c8851b67 100644
--- a/docs/core-spec/CoreLint.ott
+++ b/docs/core-spec/CoreLint.ott
@@ -222,15 +222,19 @@ k0 <: k1
--------------------- :: InstCo
G |-co g t0 : s[m |-> t0] ~#k t[n |-> t0]
-</ G |-co gi : si ~#ki ti // i />
-</ substi @ // i /> = inits(</ [ ni |-> si ] // i />)
-</ ni = zi_k'i // i />
-</ ki <: substi(k'i) // i />
-s' = s </ [ ni |-> si ] // i />
-t' = t </ [ ni |-> ti ] // i />
-G |-ty s' : k
+C = T </ axBranchkk // kk />
+0 <= ind < length </ axBranchkk // kk />
+forall </ ni // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind]
+</ G |-co gi : s'i ~#k'i t'i // i />
+</ substi @ // i /> = inits(</ [ ni |-> s'i ] // i />)
+</ ni = zi_ki // i />
+</ k'i <: substi(ki) // i />
+no_conflict(C, </ s2j // j />, ind-1)
+</ s2j = s1j </ [ni |-> s'i] // i/> // j />
+t2 = t1 </ [ni |-> t'i] // i />
+G |-ty t2 : k
------------------------------------------------------ :: AxiomInstCo
-G |-co (forall </ ni // i />. (s ~ t)) </ gi // i /> : s' ~#k t'
+G |-co C ind </ gi // i /> : T </ s2j // j /> ~#k t2
defn G |- ki k ok :: :: lintKind :: 'K_'
{{ com Kind validity, \coderef{coreSyn/CoreLint.lhs}{lintKind} }}
@@ -397,4 +401,18 @@ Constraint <: OpenKind
Constraint <: *
------------------ :: LiftedConstraint
-* <: Constraint
\ No newline at end of file
+* <: Constraint
+
+defn no_conflict ( C , </ sj // j /> , ind ) :: :: check_no_conflict :: 'NoConflict_'
+ {{ com Branched axiom conflict checking, \coderef{coreSyn/CoreLint.lhs}{lintCoercion\#check\_no\_conflict} }}
+by
+
+------------------------------------------------ :: NoBranch
+no_conflict(C, </ si // i/>, -1)
+
+C = T </ axBranchkk // kk />
+forall </ ni // i />. (</ tj // j /> ~> t') = (</ axBranchkk // kk />)[ind]
+apart(</ sj // j />, </ tj // j />)
+no_conflict(C, </ sj // j />, ind-1)
+------------------------------------------------ :: Branch
+no_conflict(C, </ sj // j />, ind)
diff --git a/docs/core-spec/CoreSyn.ott b/docs/core-spec/CoreSyn.ott
index f3e8a61eb0d27ac605ac10f05de533087a641ca7..4c59849bb665116eed019bb7da95d822e16edc8b 100644
--- a/docs/core-spec/CoreSyn.ott
+++ b/docs/core-spec/CoreSyn.ott
@@ -16,7 +16,7 @@ metavar alpha {{ tex \alpha }}, beta {{ tex \beta }} ::=
metavar N ::= {{ com Type-level constructor names }}
metavar K ::= {{ com Term-level data constructor names }}
-indexvar i, j ::= {{ com Indices to be used in lists }}
+indexvar i, j, kk {{ tex k }} ::= {{ com Indices to be used in lists }}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Syntax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -101,7 +101,7 @@ g {{ tex \gamma }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/Coercion.
| g1 g2 :: :: AppCo {{ com Application }}
| forall n . g :: :: ForAllCo {{ com Polymorphism }}
| n :: :: CoVarCo {{ com Variable }}
- | C </ gi // i /> :: :: AxiomInstCo {{ com Axiom application }}
+ | C ind </ gj // j /> :: :: AxiomInstCo {{ com Axiom application }}
| t1 ==>! t2 :: :: UnsafeCo {{ com Unsafe coercion }}
| sym g :: :: SymCo {{ com Symmetry }}
| g1 ; g2 :: :: TransCo {{ com Transitivity }}
@@ -116,9 +116,13 @@ LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/Co
| Right :: :: CRight {{ com Right projection }}
C :: 'CoAxiom_' ::= {{ com Axioms, \coderef{types/TyCon.lhs}{CoAxiom} }}
- | forall </ ni // i /> . ( s ~ t ) :: :: CoAxiom {{ com Axiom }}
+ | T </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }}
| ( C ) :: M :: Parens {{ com Parentheses }}
+axBranch, b :: 'CoAxBranch_' ::= {{ com Axiom branches, \coderef{types/TyCon.lhs}{CoAxBranch} }}
+ | forall </ ni // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }}
+ | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }}
+
%% TYCONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
T :: 'TyCon_' ::= {{ com Type constructors, \coderef{types/TyCon.lhs}{TyCon} }}
@@ -162,10 +166,13 @@ subst :: 'Subst_' ::= {{ com List of type substitutions }}
| [ n |-> t ] :: :: Mapping
| </ substi // i /> :: :: List
-nat {{ tex \mathbb{N} }} :: 'Nat_' ::= {{ com Natural numbers }}
- | i :: :: index
- | length </ ti // i /> :: M :: length
- | tyConArity T :: M :: tyConArity
+ind :: 'Ind_' ::= {{ com Indices, numbers }}
+ | i :: :: index
+ | length </ ti // i /> :: M :: length_t
+ | length </ axBranchi // i /> :: M :: length_axBranch
+ | tyConArity T :: M :: tyConArity
+ | ind - 1 :: M :: decrement
+ | -1 :: M :: minusOne
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Terminals %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -220,6 +227,8 @@ terminals :: 'terminals_' ::=
| dataConRepType :: :: dataConRepType {{ tex \textsf{dataConRepType} }}
| isNewTyCon :: :: isNewTyCon {{ tex \textsf{isNewTyCon} }}
| Constraint :: :: Constraint {{ tex \textsf{Constraint} }}
+ | no_conflict :: :: no_conflict {{ tex \textsf{no\_conflict} }}
+ | apart :: :: apart {{ tex \textsf{apart} }}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Formulae %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -233,8 +242,8 @@ formula :: 'formula_' ::=
| t1 /= t2 :: :: type_inequality
| e1 /=e e2 :: :: expr_inequality
{{ tex [[e1]] \neq [[e2]] }}
- | rf :: :: rf_formula
- | tlf :: :: tlf_formula
+ | 0 <= ind1 < ind2 :: :: in_bounds
+ {{ tex 0 \leq [[ind1]] < [[ind2]] }}
| g1 = g2 :: :: co_rewrite
| no_duplicates </ zi // i /> :: :: no_duplicates_name
| no_duplicates </ bindingi // i /> :: :: no_duplicates_binding
@@ -247,8 +256,8 @@ formula :: 'formula_' ::=
| vars1 = vars2 :: :: vars_rewrite
| </ Gi @ // i /> = inits ( </ nj // j /> ) :: :: context_folding
| </ substi @ // i /> = inits ( </ [ nj |-> tj ] // j /> ) :: :: subst_folding
- | nat1 = nat2 :: :: eq_nat
- | nat1 < nat2 :: :: lt
+ | ind1 = ind2 :: :: eq_ind
+ | ind1 < ind2 :: :: lt
| G |- tylit lit : k :: :: lintTyLit
{{ tex [[G]] \labeledjudge{tylit} [[lit]] : [[k]] }}
| isNewTyCon T :: :: isNewTyCon
@@ -258,6 +267,9 @@ formula :: 'formula_' ::=
| t is_a_coercion :: :: is_a_coercion
{{ tex \exists \tau_1, \tau_2, \kappa \text{ s.t.~} [[t]] =
\tau_1 \mathop{ {\sim}_{\#}^{\kappa} } \tau_2 }}
+ | axBranch1 = axBranch2 :: :: branch_rewrite
+ | C1 = C2 :: :: axiom_rewrite
+ | apart ( </ ti // i /> , </ sj // j /> ) :: :: apart
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Subrules and Parsing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -280,4 +292,5 @@ TyCon_PromotedTyCon right Coercion_AppCo
Subst_Mapping <= Type_TySubstList
Subst_List <= Type_TySubstList
-Subst_Mapping <= Type_TySubstListPost
\ No newline at end of file
+Subst_Mapping <= Type_TySubstListPost
+
diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng
index 4a76e46c9163e547158f8ac68871367478a2b2a0..4b1e986c6ddbdeff1011470df3e4e094a8d38ba3 100644
--- a/docs/core-spec/core-spec.mng
+++ b/docs/core-spec/core-spec.mng
@@ -145,7 +145,10 @@ Is it a left projection or a right projection?
Axioms:
-\gram{\ottC}
+\gram{
+\ottC\ottinterrule
+\ottaxBranch
+}
\subsection{Type constructors}
@@ -268,8 +271,7 @@ folding the substitution over the kinds for kind-checking.
\subsection{Name consistency}
-There are two very similar checks for names, one declared as a local function
-within \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding}:
+There are two very similar checks for names, one declared as a local function:
\ottdefnlintSingleBindingXXlintBinder{}
@@ -303,4 +305,17 @@ within \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding}:
\ottdefnisSubKind{}
+\subsection{Branched axiom conflict checking}
+
+The following judgment is used within \ottdrulename{Co\_AxiomInstCo} to make
+sure that a type family application cannot unify with any previous branch
+in the axiom.
+
+\ottdefncheckXXnoXXconflict{}
+
+The judgment $[[apart]]$ checks to see whether two lists of types are surely apart.
+It checks to see if \coderef{types/Unify.lhs}{tcApartTys} returns \texttt{SurelyApart}.
+Two types are apart if neither type is a type family application and if they do not
+unify.
+
\end{document}
diff --git a/docs/core-spec/core-spec.pdf b/docs/core-spec/core-spec.pdf
index 0e427c9c8168c8f8b640b0182377387f4fdead4d..be13ca22c55086aeed35641ebc27deea5f847af4 100644
Binary files a/docs/core-spec/core-spec.pdf and b/docs/core-spec/core-spec.pdf differ
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 4eb39c4328c8e5e691ce777ec0669181079c15f3..433aa8fa2c57719eedfd81e3df527c61b0022989 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -4861,31 +4861,66 @@ F Bool -- WRONG: unsaturated application
<sect3 id="type-instance-declarations">
<title>Type instance declarations</title>
<para>
- Instance declarations of type families are very similar to standard type
- synonym declarations. The only two differences are that the
- keyword <literal>type</literal> is followed
- by <literal>instance</literal> and that some or all of the type
- arguments can be non-variable types, but may not contain forall types or
- type synonym families. However, data families are generally allowed, and
- type synonyms are allowed as long as they are fully applied and expand
- to a type that is admissible - these are the exact same requirements as
- for data instances. For example, the <literal>[e]</literal> instance
- for <literal>Elem</literal> is
+ There are two forms of type family instance declaration: unbranched and
+ branched. Branched instances list any number of alternatives, to be
+ checked in order from top to bottom, similarly to normal function
+ declarations. Unbranched instances supply only one left-hand side.
+
+ Unbranched instance declarations of type families are very similar to
+ standard type synonym declarations. The only two differences are that
+ the keyword <literal>type</literal> is followed by
+ <literal>instance</literal> and that some or all of the type arguments
+ can be non-variable types, but may not contain forall types or type
+ synonym families. However, data families are generally allowed, and type
+ synonyms are allowed as long as they are fully applied and expand to a
+ type that is admissible - these are the exact same requirements as for
+ data instances. For example, the <literal>[e]</literal> instance for
+ <literal>Elem</literal> is
<programlisting>
type instance Elem [e] = e
</programlisting>
</para>
+
+ <para>
+ Branched instance declarations, on the other hand, allow many different
+ left-hand-side type patterns. These patterns are tried in order, from
+ top to bottom, when simplifying a type family application. A branched instance
+ declaration is introduced by <literal>type instance where</literal>. For example:
+<programlisting>
+type instance where
+ F Int = Double
+ F Bool = Char
+ F a = String
+</programlisting>
+ In this example, we declare an instance for <literal>F</literal> such
+ that <literal>F Int</literal> simplifies to <literal>Double</literal>,
+ <literal>F Bool</literal> simplifies to <literal>Char</literal>, and for
+ any other type <literal>a</literal> that is known not to be
+ <literal>Int</literal> or <literal>Bool</literal>, <literal>F
+ a</literal> simplifies to <literal>String</literal>. Note that GHC must
+ be sure that <literal>a</literal> cannot unify with
+ <literal>Int</literal> or <literal>Bool</literal> in that last case; if
+ a programmer specifies just <literal>F a</literal> in their code, GHC will
+ not be able to simplify the type. After all, <literal>a</literal> might later
+ be instantiated with <literal>Int</literal>.
+ </para>
+
+ <para>
+ Branched instances and unbranched instances may be mixed freely for the same
+ type family.
+ </para>
+
<para>
Type family instance declarations are only legitimate when an
appropriate family declaration is in scope - just like class instances
- require the class declaration to be visible. Moreover, each instance
+ require the class declaration to be visible. Moreover, each instance
declaration has to conform to the kind determined by its family
declaration, and the number of type parameters in an instance
declaration must match the number of type parameters in the family
- declaration. Finally, the right-hand side of a type instance must be a
+ declaration. Finally, the right-hand side of a type instance must be a
monotype (i.e., it may not include foralls) and after the expansion of
all saturated vanilla type synonyms, no synonyms, except family synonyms
- may remain. Here are some examples of admissible and illegal type
+ may remain. Here are some examples of admissible and illegal type
instances:
<programlisting>
type family F a :: *
@@ -4894,6 +4929,13 @@ type instance F String = Char -- OK!
type instance F (F a) = a -- WRONG: type parameter mentions a type family
type instance F (forall a. (a, b)) = b -- WRONG: a forall type appears in a type parameter
type instance F Float = forall a.a -- WRONG: right-hand side may not be a forall type
+type instance where -- OK!
+ F (Maybe Int) = Int
+ F (Maybe Bool) = Bool
+ F (Maybe a) = String
+type instance where -- WRONG: conflicts with earlier instances (see below)
+ F Int = Float
+ F a = [a]
type family G a b :: * -> *
type instance G Int = (,) -- WRONG: must be two type parameters
@@ -4904,15 +4946,17 @@ type instance G Int Char Float = Double -- WRONG: must be two type parameters
<sect3 id="type-family-overlap">
<title>Overlap of type synonym instances</title>
<para>
- The instance declarations of a type family used in a single program
- may only overlap if the right-hand sides of the overlapping instances
- coincide for the overlapping types. More formally, two instance
- declarations overlap if there is a substitution that makes the
- left-hand sides of the instances syntactically the same. Whenever
- that is the case, the right-hand sides of the instances must also be
- syntactically equal under the same substitution. This condition is
- independent of whether the type family is associated or not, and it is
- not only a matter of consistency, but one of type safety.
+ The unbranched instance declarations of a type family used in a single
+ program may only overlap if the right-hand sides of the overlapping
+ instances coincide for the overlapping types. More formally, two
+ instance declarations overlap if there is a substitution that makes
+ the left-hand sides of the instances syntactically the same. Whenever
+ that is the case, if the instances are unbranched, the right-hand
+ sides of the instances must also be syntactically equal under the same
+ substitution. This condition is independent of whether the type family
+ is associated or not, and it is not only a matter of consistency, but
+ one of type safety. Branched instances are not permitted to overlap
+ with any other instances, branched or unbranched.
</para>
<para>
Here are two example to illustrate the condition under which overlap
@@ -4923,6 +4967,10 @@ type instance F (Int, b) = [b] -- overlap permitted
type instance G (a, Int) = [a]
type instance G (Char, a) = [a] -- ILLEGAL overlap, as [Char] /= [Int]
+
+type instance H Int = Int
+type instance where -- ILLEGAL overlap, as branched instances may not overlap
+ H a = a
</programlisting>
</para>
<para> However see <xref linkend="ghci-decls"/> for the overlap rules in GHCi.</para>
@@ -5055,6 +5103,10 @@ instance GMapKey Flob where
the free indexed parameter is of a kind with a finite number of alternatives
(unlike <literal>*</literal>).
</para>
+
+ <para>
+ Branched associated type instances are not currently supported.
+ </para>
</sect3>
<sect3 id="assoc-decl-defs">
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index c0d5f19233a2181be8ce9ffe37e903de30671afb..93275464e8f053566b1829b7cf74528c34e33017 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -2180,7 +2180,7 @@ showBindings = do
docs <- mapM makeDoc (reverse bindings)
-- reverse so the new ones come last
let idocs = map GHC.pprInstanceHdr insts
- fidocs = map GHC.pprFamInstHdr finsts
+ fidocs = map GHC.pprFamInst finsts
mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
where
makeDoc (AnId i) = pprTypeAndContents i