Commit 569b2652 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Revise implementation of overlapping type family instances.

This commit changes the syntax and story around overlapping type
family instances. Before, we had "unbranched" instances and
"branched" instances. Now, we have closed type families and
open ones.

The behavior of open families is completely unchanged. In particular,
coincident overlap of open type family instances still works, despite
emails to the contrary.

A closed type family is declared like this:
> type family F a where
>   F Int = Bool
>   F a   = Char
The equations are tried in order, from top to bottom, subject to
certain constraints, as described in the user manual. It is not
allowed to declare an instance of a closed family.
parent 11db9cf8
...@@ -939,7 +939,7 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -939,7 +939,7 @@ lintCoercion co@(AxiomInstCo con ind cos)
; let lhs' = Type.substTys subst_l lhs ; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of ; case checkAxInstCo co of
Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index) Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
Nothing -> return () Nothing -> return ()
; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') } ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
where where
......
...@@ -258,18 +258,29 @@ repSynDecl tc bndrs ty ...@@ -258,18 +258,29 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 } ; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour, repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
fdLName = tc, fdLName = tc,
fdTyVars = tvs, fdTyVars = tvs,
fdKindSig = opt_kind })) fdKindSig = opt_kind }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs -> ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
do { flav <- repFamilyFlavour flavour case (opt_kind, info) of
; case opt_kind of (Nothing, ClosedTypeFamily eqns) ->
Nothing -> repFamilyNoKind flav tc1 bndrs do { eqns1 <- mapM repTyFamEqn eqns
Just ki -> do { ki1 <- repLKind ki ; eqns2 <- coreList tySynEqnQTyConName eqns1
; repFamilyKind flav tc1 bndrs ki1 } ; repClosedFamilyNoKind tc1 bndrs eqns2 }
} (Just ki, ClosedTypeFamily eqns) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; ki1 <- repLKind ki
; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
(Nothing, _) ->
do { info' <- repFamilyInfo info
; repFamilyNoKind info' tc1 bndrs }
(Just ki, _) ->
do { info' <- repFamilyInfo info
; ki1 <- repLKind ki
; repFamilyKind info' tc1 bndrs ki1 }
; return (loc, dec) ; return (loc, dec)
} }
...@@ -317,9 +328,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs ...@@ -317,9 +328,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
-- represent family declaration flavours -- represent family declaration flavours
-- --
repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName [] repFamilyInfo OpenTypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName [] repFamilyInfo DataFamily = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
-- Represent instance declarations -- Represent instance declarations
-- --
...@@ -362,12 +374,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ...@@ -362,12 +374,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns }) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
= do { let tc_name = tyFamInstDeclLName decl = do { let tc_name = tyFamInstDeclLName decl
; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; eqns1 <- mapM repTyFamEqn eqns ; eqn1 <- repTyFamEqn eqn
; eqns2 <- coreList tySynEqnQTyConName eqns1 ; repTySynInst tc eqn1 }
; repTySynInst tc eqns2 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
...@@ -1688,9 +1699,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] ...@@ -1688,9 +1699,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki] = rep2 familyKindDName [flav, nm, tvs, ki]
repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
repTySynInst (MkC nm) (MkC eqns) repTySynInst (MkC nm) (MkC eqn)
= rep2 tySynInstDName [nm, eqns] = rep2 tySynInstDName [nm, eqn]
repClosedFamilyNoKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
= rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
repClosedFamilyKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core TH.Kind
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
= rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC lhs) (MkC rhs) repTySynEqn (MkC lhs) (MkC rhs)
...@@ -1994,7 +2020,8 @@ templateHaskellNames = [ ...@@ -1994,7 +2020,8 @@ templateHaskellNames = [
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragRuleDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
tySynInstDName, infixLDName, infixRDName, infixNDName, tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName,
-- Cxt -- Cxt
cxtName, cxtName,
-- Pred -- Pred
...@@ -2207,6 +2234,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, ...@@ -2207,6 +2234,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName :: Name infixLDName, infixRDName, infixNDName :: Name
funDName = libFun (fsLit "funD") funDIdKey funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey valDName = libFun (fsLit "valD") valDIdKey
...@@ -2227,6 +2255,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey ...@@ -2227,6 +2255,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
closedTypeFamilyKindDName
= libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
closedTypeFamilyNoKindDName
= libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
infixLDName = libFun (fsLit "infixLD") infixLDIdKey infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey infixNDName = libFun (fsLit "infixND") infixNDIdKey
...@@ -2543,29 +2575,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, ...@@ -2543,29 +2575,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
familyNoKindDIdKey, familyKindDIdKey, familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330 funDIdKey = mkPreludeMiscIdUnique 330
valDIdKey = mkPreludeMiscIdUnique 331 valDIdKey = mkPreludeMiscIdUnique 331
dataDIdKey = mkPreludeMiscIdUnique 332 dataDIdKey = mkPreludeMiscIdUnique 332
newtypeDIdKey = mkPreludeMiscIdUnique 333 newtypeDIdKey = mkPreludeMiscIdUnique 333
tySynDIdKey = mkPreludeMiscIdUnique 334 tySynDIdKey = mkPreludeMiscIdUnique 334
classDIdKey = mkPreludeMiscIdUnique 335 classDIdKey = mkPreludeMiscIdUnique 335
instanceDIdKey = mkPreludeMiscIdUnique 336 instanceDIdKey = mkPreludeMiscIdUnique 336
sigDIdKey = mkPreludeMiscIdUnique 337 sigDIdKey = mkPreludeMiscIdUnique 337
forImpDIdKey = mkPreludeMiscIdUnique 338 forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339 pragInlDIdKey = mkPreludeMiscIdUnique 339
pragSpecDIdKey = mkPreludeMiscIdUnique 340 pragSpecDIdKey = mkPreludeMiscIdUnique 340
pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
pragSpecInstDIdKey = mkPreludeMiscIdUnique 412 pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
pragRuleDIdKey = mkPreludeMiscIdUnique 413 pragRuleDIdKey = mkPreludeMiscIdUnique 413
familyNoKindDIdKey = mkPreludeMiscIdUnique 342 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
familyKindDIdKey = mkPreludeMiscIdUnique 343 familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344 dataInstDIdKey = mkPreludeMiscIdUnique 344
newtypeInstDIdKey = mkPreludeMiscIdUnique 345 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
tySynInstDIdKey = mkPreludeMiscIdUnique 346 tySynInstDIdKey = mkPreludeMiscIdUnique 346
infixLDIdKey = mkPreludeMiscIdUnique 347 closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347
infixRDIdKey = mkPreludeMiscIdUnique 348 closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
infixNDIdKey = mkPreludeMiscIdUnique 349 infixLDIdKey = mkPreludeMiscIdUnique 349
infixRDIdKey = mkPreludeMiscIdUnique 350
infixNDIdKey = mkPreludeMiscIdUnique 351
-- type Cxt = ... -- type Cxt = ...
cxtIdKey :: Unique cxtIdKey :: Unique
......
...@@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind) ...@@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind)
; kind' <- cvtMaybeKind kind ; kind' <- cvtMaybeKind kind
; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) } ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
where where
cvtFamFlavour TypeFam = TypeFamily cvtFamFlavour TypeFam = OpenTypeFamily
cvtFamFlavour DataFam = DataFamily cvtFamFlavour DataFam = DataFamily
cvtDec (DataInstD ctxt tc tys constrs derivs) cvtDec (DataInstD ctxt tc tys constrs derivs)
...@@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) ...@@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn, dfid_fvs = placeHolderNames } }} , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqns) cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc = do { tc' <- tconNameL tc
; eqns' <- mapM (cvtTySynEqn tc') eqns ; eqn' <- cvtTySynEqn tc' eqn
; returnL $ InstD $ TyFamInstD ; returnL $ InstD $ TyFamInstD
{ tfid_inst = TyFamInstDecl { tfid_eqns = eqns' { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_group = (length eqns' /= 1)
, tfid_fvs = placeHolderNames } } } , tfid_fvs = placeHolderNames } } }
cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
; mkind' <- cvtMaybeKind mkind
; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
---------------- ----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs) cvtTySynEqn tc (TySynEqn lhs rhs)
......
...@@ -24,7 +24,7 @@ module HsDecls ( ...@@ -24,7 +24,7 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl, FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations -- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamInstEqn(..), LTyFamInstEqn, TyFamInstEqn(..), LTyFamInstEqn,
...@@ -470,16 +470,17 @@ data TyClDecl name ...@@ -470,16 +470,17 @@ data TyClDecl name
type LFamilyDecl name = Located (FamilyDecl name) type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl data FamilyDecl name = FamilyDecl
{ fdFlavour :: FamilyFlavour -- type or data { fdInfo :: FamilyInfo name -- type or data, closed or open
, fdLName :: Located name -- type constructor , fdLName :: Located name -- type constructor
, fdTyVars :: LHsTyVarBndrs name -- type variables , fdTyVars :: LHsTyVarBndrs name -- type variables
, fdKindSig :: Maybe (LHsKind name) } -- result kind , fdKindSig :: Maybe (LHsKind name) } -- result kind
deriving( Data, Typeable ) deriving( Data, Typeable )
data FamilyFlavour data FamilyInfo name
= TypeFamily = DataFamily
| DataFamily | OpenTypeFamily
deriving( Data, Typeable, Eq ) | ClosedTypeFamily [LTyFamInstEqn name]
deriving( Data, Typeable )
\end{code} \end{code}
...@@ -510,12 +511,15 @@ isFamilyDecl _other = False ...@@ -510,12 +511,15 @@ isFamilyDecl _other = False
-- | type family declaration -- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool isTypeFamilyDecl :: TyClDecl name -> Bool
isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
isTypeFamilyDecl _other = False OpenTypeFamily -> True
ClosedTypeFamily {} -> True
_ -> False
isTypeFamilyDecl _ = False
-- | data family declaration -- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool isDataFamilyDecl :: TyClDecl name -> Bool
isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
isDataFamilyDecl _other = False isDataFamilyDecl _other = False
\end{code} \end{code}
...@@ -528,11 +532,9 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName ...@@ -528,11 +532,9 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: OutputableBndr name tyFamInstDeclLName :: OutputableBndr name
=> TyFamInstDecl name -> Located name => TyFamInstDecl name -> Located name
tyFamInstDeclLName (TyFamInstDecl { tfid_eqns = tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(L _ (TyFamInstEqn { tfie_tycon = ln })) : _ }) (L _ (TyFamInstEqn { tfie_tycon = ln })) })
-- there may be more than one equation, but grab the name from the first
= ln = ln
tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
tyClDeclLName :: TyClDecl name -> Located name tyClDeclLName :: TyClDecl name -> Located name
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
...@@ -598,17 +600,26 @@ instance OutputableBndr name ...@@ -598,17 +600,26 @@ instance OutputableBndr name
<+> pprFundeps (map unLoc fds) <+> pprFundeps (map unLoc fds)
instance (OutputableBndr name) => Outputable (FamilyDecl name) where instance (OutputableBndr name) => Outputable (FamilyDecl name) where
ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon, ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
fdTyVars = tyvars, fdKindSig = mb_kind}) fdTyVars = tyvars, fdKindSig = mb_kind})
= ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
, nest 2 $ pp_eqns ]
where where
pp_kind = case mb_kind of pp_kind = case mb_kind of
Nothing -> empty Nothing -> empty
Just kind -> dcolon <+> ppr kind Just kind -> dcolon <+> ppr kind
(pp_where, pp_eqns) = case info of
ClosedTypeFamily eqns -> ( ptext (sLit "where")
, vcat $ map ppr eqns )
_ -> (empty, empty)
pprFlavour :: FamilyInfo name -> SDoc
pprFlavour DataFamily = ptext (sLit "data family")
pprFlavour OpenTypeFamily = ptext (sLit "type family")
pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
instance Outputable FamilyFlavour where instance Outputable (FamilyInfo name) where
ppr TypeFamily = ptext (sLit "type family") ppr = pprFlavour
ppr DataFamily = ptext (sLit "data family")
pp_vanilla_decl_head :: OutputableBndr name pp_vanilla_decl_head :: OutputableBndr name
=> Located name => Located name
...@@ -838,10 +849,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { ...@@ -838,10 +849,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
\begin{code} \begin{code}
----------------- Type synonym family instances ------------- ----------------- Type synonym family instances -------------
-- See note [Family instance equation groups]
type LTyFamInstEqn name = Located (TyFamInstEqn name) type LTyFamInstEqn name = Located (TyFamInstEqn name)
-- | One equation in a family instance declaration -- | One equation in a type family instance declaration
data TyFamInstEqn name data TyFamInstEqn name
= TyFamInstEqn = TyFamInstEqn
{ tfie_tycon :: Located name { tfie_tycon :: Located name
...@@ -854,15 +864,10 @@ data TyFamInstEqn name ...@@ -854,15 +864,10 @@ data TyFamInstEqn name
type LTyFamInstDecl name = Located (TyFamInstDecl name) type LTyFamInstDecl name = Located (TyFamInstDecl name)
data TyFamInstDecl name data TyFamInstDecl name
= TyFamInstDecl = TyFamInstDecl
{ tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns { tfid_eqn :: LTyFamInstEqn name
-- Always non-empty , tfid_fvs :: NameSet }
, 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 ) deriving( Typeable, Data )
----------------- Data family instances ------------- ----------------- Data family instances -------------
type LDataFamInstDecl name = Located (DataFamInstDecl name) type LDataFamInstDecl name = Located (DataFamInstDecl name)
...@@ -925,24 +930,13 @@ tvs are fv(pat_tys), *including* ones that are already in scope ...@@ -925,24 +930,13 @@ 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 so that we can compare the type patter in the 'instance' decl and
in the associated 'type' decl in the associated 'type' decl
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.
\begin{code} \begin{code}
instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
ppr = pprTyFamInstDecl TopLevel ppr = pprTyFamInstDecl TopLevel
pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] }) pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns })
= hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where"))
2 (vcat (map ppr eqns))
ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = ptext (sLit "instance") ppr_instance_keyword TopLevel = ptext (sLit "instance")
......
...@@ -1307,27 +1307,30 @@ instance Binary IfaceDecl where ...@@ -1307,27 +1307,30 @@ instance Binary IfaceDecl where
return (IfaceAxiom occ a2 a3) return (IfaceAxiom occ a2 a3)
instance Binary IfaceAxBranch where instance Binary IfaceAxBranch where
put_ bh (IfaceAxBranch a1 a2 a3) = do put_ bh (IfaceAxBranch a1 a2 a3 a4) = do
put_ bh a1 put_ bh a1
put_ bh a2 put_ bh a2
put_ bh a3 put_ bh a3
put_ bh a4
get bh = do get bh = do
a1 <- get bh a1 <- get bh
a2 <- get bh a2 <- get bh
a3 <- get bh a3 <- get bh
return (IfaceAxBranch a1 a2 a3) a4 <- get bh
return (IfaceAxBranch a1 a2 a3 a4)
instance Binary ty => Binary (SynTyConRhs ty) where instance Binary IfaceSynTyConRhs where
put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax
put_ bh (IfaceSynonymTyCon ty) = putByte bh 2 >> put_ bh ty
get bh = do { h <- getByte bh get bh = do { h <- getByte bh
; case h of ; case h of
0 -> do { a <- get bh 0 -> do { return IfaceOpenSynFamilyTyCon }
; b <- get bh 1 -> do { ax <- get bh
; return (SynFamilyTyCon a b) } ; return (IfaceClosedSynFamilyTyCon ax) }
_ -> do { ty <- get bh _ -> do { ty <- get bh
; return (SynonymTyCon ty) } } ; return (IfaceSynonymTyCon ty) } }
instance Binary IfaceClsInst where instance Binary IfaceClsInst where
put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh (IfaceClsInst cls tys dfun flag orph) = do
...@@ -1345,19 +1348,17 @@ instance Binary IfaceClsInst where ...@@ -1345,19 +1348,17 @@ instance Binary IfaceClsInst where
return (IfaceClsInst cls tys dfun flag orph) return (IfaceClsInst cls tys dfun flag orph)
instance Binary IfaceFamInst where instance Binary IfaceFamInst where
put_ bh (IfaceFamInst fam group tys name orph) = do put_ bh (IfaceFamInst fam tys name orph) = do
put_ bh fam put_ bh fam
put_ bh group
put_ bh tys put_ bh tys
put_ bh name put_ bh name
put_ bh orph put_ bh orph
get bh = do get bh = do
fam <- get bh fam <- get bh
group <- get bh
tys <- get bh tys <- get bh
name <- get bh name <- get bh
orph <- get bh orph <- get bh
return (IfaceFamInst fam group tys name orph) return (IfaceFamInst fam tys name orph)
instance Binary OverlapFlag where instance Binary OverlapFlag where
put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
......
...@@ -47,7 +47,7 @@ import Outputable ...@@ -47,7 +47,7 @@ import Outputable
\begin{code} \begin{code}
------------------------------------------------------ ------------------------------------------------------
buildSynTyCon :: Name -> [TyVar] buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs Type -> SynTyConRhs
-> Kind -- ^ Kind of the RHS -> Kind -- ^ Kind of the RHS
-> TyConParent -> TyConParent
-> TcRnIf m n TyCon -> TcRnIf m n TyCon
......
...@@ -57,7 +57,7 @@ import Data.IORef ( atomicModifyIORef, readIORef ) ...@@ -57,7 +57,7 @@ import Data.IORef ( atomicModifyIORef, readIORef )
Note [The Name Cache] Note [The Name Cache]
~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~
The Name Cache makes sure that, during any invocation of GHC, each The Name Cache makes sure that, during any invovcation of GHC, each
External Name "M.x" has one, and only one globally-agreed Unique. External Name "M.x" has one, and only one globally-agreed Unique.
* The first time we come across M.x we make up a Unique and record that * The first time we come across M.x we make up a Unique and record that
......
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
module IfaceSyn ( module IfaceSyn (
module IfaceType, module IfaceType,
IfaceDecl(..), IfaceClassOp(..), IfaceAT(..), IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceBinding(..), IfaceConAlt(..),
...@@ -36,13 +36,13 @@ module IfaceSyn ( ...@@ -36,13 +36,13 @@ module IfaceSyn (
#include "HsVersions.h" #include "HsVersions.h"
import TyCon( SynTyConRhs(..) )
import IfaceType import IfaceType
import PprCore() -- Printing DFunArgs import PprCore() -- Printing DFunArgs
import Demand import Demand
import Annotations import Annotations
import Class import Class