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)
; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs
; 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 ()
; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
where
......
......@@ -258,18 +258,29 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
fdLName = tc,
fdTyVars = tvs,
fdKindSig = opt_kind }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
do { flav <- repFamilyFlavour flavour
; case opt_kind of
Nothing -> repFamilyNoKind flav tc1 bndrs
Just ki -> do { ki1 <- repLKind ki
; repFamilyKind flav tc1 bndrs ki1 }
}
case (opt_kind, info) of
(Nothing, ClosedTypeFamily eqns) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; repClosedFamilyNoKind tc1 bndrs eqns2 }
(Just ki, ClosedTypeFamily eqns) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; ki1 <- repLKind ki
; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
(Nothing, _) ->
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)
}
......@@ -317,9 +328,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
-- represent family declaration flavours
--
repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName []
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily = rep2 typeFamName []
repFamilyInfo DataFamily = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
-- Represent instance declarations
--
......@@ -362,12 +374,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
= do { let tc_name = tyFamInstDeclLName decl
; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; repTySynInst tc eqns2 }
; eqn1 <- repTyFamEqn eqn
; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
......@@ -1688,9 +1699,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki]
repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ)
repTySynInst (MkC nm) (MkC eqns)
= rep2 tySynInstDName [nm, eqns]
repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
repTySynInst (MkC nm) (MkC eqn)
= rep2 tySynInstDName [nm, eqn]
repClosedFamilyNoKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
= rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
repClosedFamilyKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core TH.Kind
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
= rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC lhs) (MkC rhs)
......@@ -1994,7 +2020,8 @@ templateHaskellNames = [
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
tySynInstDName, infixLDName, infixRDName, infixNDName,
tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName,
-- Cxt
cxtName,
-- Pred
......@@ -2207,6 +2234,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
......@@ -2227,6 +2255,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
closedTypeFamilyKindDName
= libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
closedTypeFamilyNoKindDName
= libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey
......@@ -2543,6 +2575,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330
valDIdKey = mkPreludeMiscIdUnique 331
......@@ -2563,9 +2596,11 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344
newtypeInstDIdKey = mkPreludeMiscIdUnique 345
tySynInstDIdKey = mkPreludeMiscIdUnique 346
infixLDIdKey = mkPreludeMiscIdUnique 347
infixRDIdKey = mkPreludeMiscIdUnique 348
infixNDIdKey = mkPreludeMiscIdUnique 349
closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347
closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
infixLDIdKey = mkPreludeMiscIdUnique 349
infixRDIdKey = mkPreludeMiscIdUnique 350
infixNDIdKey = mkPreludeMiscIdUnique 351
-- type Cxt = ...
cxtIdKey :: Unique
......
......@@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind)
; kind' <- cvtMaybeKind kind
; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
where
cvtFamFlavour TypeFam = TypeFamily
cvtFamFlavour TypeFam = OpenTypeFamily
cvtFamFlavour DataFam = DataFamily
cvtDec (DataInstD ctxt tc tys constrs derivs)
......@@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn, dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqns)
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
; eqns' <- mapM (cvtTySynEqn tc') eqns
; eqn' <- cvtTySynEqn tc' eqn
; returnL $ InstD $ TyFamInstD
{ tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
, tfid_group = (length eqns' /= 1)
{ tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames } } }
cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
; mkind' <- cvtMaybeKind mkind
; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
......
......@@ -24,7 +24,7 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamInstEqn(..), LTyFamInstEqn,
......@@ -470,16 +470,17 @@ data TyClDecl name
type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
{ fdFlavour :: FamilyFlavour -- type or data
{ fdInfo :: FamilyInfo name -- type or data, closed or open
, fdLName :: Located name -- type constructor
, fdTyVars :: LHsTyVarBndrs name -- type variables
, fdKindSig :: Maybe (LHsKind name) } -- result kind
deriving( Data, Typeable )
data FamilyFlavour
= TypeFamily
| DataFamily
deriving( Data, Typeable, Eq )
data FamilyInfo name
= DataFamily
| OpenTypeFamily
| ClosedTypeFamily [LTyFamInstEqn name]
deriving( Data, Typeable )
\end{code}
......@@ -510,12 +511,15 @@ isFamilyDecl _other = False
-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily
isTypeFamilyDecl _other = False
isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
OpenTypeFamily -> True
ClosedTypeFamily {} -> True
_ -> False
isTypeFamilyDecl _ = False
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily
isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
isDataFamilyDecl _other = False
\end{code}
......@@ -528,11 +532,9 @@ 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
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(L _ (TyFamInstEqn { tfie_tycon = ln })) })
= ln
tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
tyClDeclLName :: TyClDecl name -> Located name
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
......@@ -598,17 +600,26 @@ instance OutputableBndr name
<+> pprFundeps (map unLoc fds)
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon,
ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
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
pp_kind = case mb_kind of
Nothing -> empty
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
ppr TypeFamily = ptext (sLit "type family")
ppr DataFamily = ptext (sLit "data family")
instance Outputable (FamilyInfo name) where
ppr = pprFlavour
pp_vanilla_decl_head :: OutputableBndr name
=> Located name
......@@ -838,10 +849,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
\begin{code}
----------------- Type synonym family instances -------------
-- See note [Family instance equation groups]
type LTyFamInstEqn name = Located (TyFamInstEqn name)
-- | One equation in a family instance declaration
-- | One equation in a type family instance declaration
data TyFamInstEqn name
= TyFamInstEqn
{ tfie_tycon :: Located name
......@@ -854,15 +864,10 @@ data TyFamInstEqn name
type LTyFamInstDecl name = Located (TyFamInstDecl name)
data TyFamInstDecl name
= TyFamInstDecl
{ tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns
-- Always non-empty
, 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
{ tfid_eqn :: LTyFamInstEqn name
, tfid_fvs :: NameSet }
deriving( Typeable, Data )
----------------- Data family instances -------------
type LDataFamInstDecl name = Located (DataFamInstDecl name)
......@@ -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
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}
instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
ppr = pprTyFamInstDecl TopLevel
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)
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 TopLevel = ptext (sLit "instance")
......
......@@ -1307,27 +1307,30 @@ instance Binary IfaceDecl where
return (IfaceAxiom occ a2 a3)
instance Binary IfaceAxBranch where
put_ bh (IfaceAxBranch a1 a2 a3) = do
put_ bh (IfaceAxBranch a1 a2 a3 a4) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
get bh = do
a1 <- get bh
a2 <- 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
put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b
put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty
instance Binary IfaceSynTyConRhs where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
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
; case h of
0 -> do { a <- get bh
; b <- get bh
; return (SynFamilyTyCon a b) }
0 -> do { return IfaceOpenSynFamilyTyCon }
1 -> do { ax <- get bh
; return (IfaceClosedSynFamilyTyCon ax) }
_ -> do { ty <- get bh
; return (SynonymTyCon ty) } }
; return (IfaceSynonymTyCon ty) } }
instance Binary IfaceClsInst where
put_ bh (IfaceClsInst cls tys dfun flag orph) = do
......@@ -1345,19 +1348,17 @@ instance Binary IfaceClsInst where
return (IfaceClsInst cls tys dfun flag orph)
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 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 group tys name orph)
return (IfaceFamInst fam tys name orph)
instance Binary OverlapFlag where
put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
......
......@@ -47,7 +47,7 @@ import Outputable
\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs Type
-> SynTyConRhs
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
......
......@@ -57,7 +57,7 @@ import Data.IORef ( atomicModifyIORef, readIORef )
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.
* The first time we come across M.x we make up a Unique and record that
......
......@@ -14,7 +14,7 @@
module IfaceSyn (
module IfaceType,
IfaceDecl(..), IfaceClassOp(..), IfaceAT(..),
IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..),
......@@ -36,13 +36,13 @@ module IfaceSyn (
#include "HsVersions.h"
import TyCon( SynTyConRhs(..) )
import IfaceType
import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
import NameSet
import CoAxiom ( BranchIndex )
import Name
import CostCentre
import Literal
......@@ -91,7 +91,7 @@ data IfaceDecl
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: SynTyConRhs IfaceType }
ifSynRhs :: IfaceSynTyConRhs }
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class TyCon
......@@ -112,6 +112,11 @@ data IfaceDecl
-- beyond .NET
ifExtName :: Maybe FastString }
data IfaceSynTyConRhs
= IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom
| IfaceSynonymTyCon IfaceType
data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-- Nothing => no default method
-- Just False => ordinary polymorphic default method
......@@ -122,13 +127,35 @@ data IfaceAT = IfaceAT IfaceDecl [IfaceAxBranch]
-- Just ds => default associated type instance from these templates
instance Outputable IfaceAxBranch where
ppr (IfaceAxBranch { ifaxbTyVars = tvs, ifaxbLHS = pat_tys, ifaxbRHS = ty })
= ppr tvs <+> hsep (map ppr pat_tys) <+> char '=' <+> ppr ty
ppr = pprAxBranch Nothing
pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc
pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs
, ifaxbLHS = pat_tys
, ifaxbRHS = ty
, ifaxbIncomps = incomps })
= ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$
nest 4 maybe_incomps
where
ppr_lhs
| Just tycon <- mtycon
= ppr (IfaceTyConApp tycon pat_tys)
| otherwise
= hsep (map ppr pat_tys)
maybe_incomps
| [] <- incomps
= empty
| otherwise
= parens (ptext (sLit "incompatible indices:") <+> ppr incomps)
-- this is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbLHS :: [IfaceType]
, ifaxbRHS :: IfaceType }
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
-- See Note [Storing compatibility] in CoAxiom
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
......@@ -173,12 +200,10 @@ data IfaceClsInst
-- 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]].
-- match types
data IfaceFamInst
= IfaceFamInst { ifFamInstFam :: IfExtName -- Family name
, ifFamInstBranched :: Bool -- Is this branched?
, ifFamInstTys :: [[Maybe IfaceTyCon]] -- See above
, ifFamInstTys :: [Maybe IfaceTyCon] -- See above
, ifFamInstAxiom :: IfExtName -- The axiom
, ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst
}
......@@ -497,15 +522,20 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
pprIfaceDecl (IfaceSyn {ifName = tycon,
ifTyVars = tyvars,
ifSynRhs = SynonymTyCon mono_ty})
ifSynRhs = IfaceSynonymTyCon mono_ty})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind })
ifSynRhs = IfaceOpenSynFamilyTyCon, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = IfaceClosedSynFamilyTyCon {}, ifSynKind = kind })
= hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
......@@ -535,10 +565,7 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
= hang (ptext (sLit "axiom") <+> ppr name <> colon)
2 (vcat $ map ppr_branch branches)
where
ppr_branch (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs })
= pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tycon lhs) <+> text "~#" <+> ppr rhs
2 (vcat $ map (pprAxBranch $ Just tycon) branches)
pprCType :: Maybe CType -> SDoc
pprCType Nothing = ptext (sLit "No C type associated")
......@@ -623,10 +650,10 @@ instance Outputable IfaceClsInst where
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcss,
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstAxiom = tycon_ax})
= hang (ptext (sLit "family instance") <+>
ppr fam <+> pprWithCommas (brackets . pprWithCommas ppr_rough) mb_tcss)
ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
2 (equals <+> ppr tycon_ax)
ppr_rough :: Maybe IfaceTyCon -> SDoc
......@@ -820,9 +847,10 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet
freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty
freeNamesIfSynRhs _ = emptyNameSet
freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet
freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty
freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......
......@@ -90,7 +90,7 @@ newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
-- Coercion constructors
data IfaceCoCon
= IfaceCoAx IfExtName Int -- Int is 0-indexed branch number
= IfaceCoAx IfExtName BranchIndex -- BranchIndex is 0-indexed branch number
| IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
| IfaceTransCo | IfaceInstCo
| IfaceNthCo Int | IfaceLRCo LeftOrRight
......
......@@ -311,7 +311,6 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
}
; (new_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
addFingerprints hsc_env maybe_old_fingerprint
......@@ -1445,16 +1444,33 @@ coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches })
= IfaceAxiom { ifName = name
, ifTyCon = toIfaceTyCon tycon
, ifAxBranches = brListMap (coAxBranchToIfaceBranch emptyTidyEnv) branches }
, ifAxBranches = brListMap (coAxBranchToIfaceBranch
emptyTidyEnv
(brListMap coAxBranchLHS branches)) branches }
where
name = getOccName ax
coAxBranchToIfaceBranch :: TidyEnv -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch env0 (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
-- to incompatible indices
-- See [Storing compatibility] in CoAxiom
coAxBranchToIfaceBranch :: TidyEnv -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch env0 lhs_s
branch@(CoAxBranch { cab_incomps = incomps })
= (coAxBranchToIfaceBranch' env0 branch) { ifaxbIncomps = iface_incomps }
where
iface_incomps = map (expectJust "iface_incomps"
. (flip findIndex lhs_s
. eqTypes)
. coAxBranchLHS) incomps
-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' env0
(CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
, ifaxbLHS = map (tidyToIfaceType env1) lhs
, ifaxbRHS = tidyToIfaceType env1 rhs }
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
(env1, tv_bndrs) = tidyTyVarBndrs env0 tvs
......@@ -1491,8 +1507,9 @@ tyConToIfaceDecl env tycon
where
(env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b
to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty)
to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon