** This patch changes the interface file format. All libraries etc **
** need to be compiled from scratch. **
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh a6
put_ bh a7
put_ bh a8
- put_ bh (IfaceSyn aq ar as at) = do
+ put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
- put_ bh (occNameFS aq)
- put_ bh ar
- put_ bh as
- put_ bh at
+ put_ bh (occNameFS a1)
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
put_ bh a1
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
put_ bh a1
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
3 -> do
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
3 -> do
- aq <- get bh
- ar <- get bh
- as <- get bh
- at <- get bh
- occ <- return $! mkOccNameFS tcName aq
- return (IfaceSyn occ ar as at)
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ occ <- return $! mkOccNameFS tcName a1
+ return (IfaceSyn occ a2 a3 a4 a5)
_ -> do
a1 <- get bh
a2 <- get bh
_ -> do
a1 <- get bh
a2 <- get bh
-- current compilation unit
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- current compilation unit
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
+ -- Invariant:
+ -- ifCons /= IfOpenDataTyCon
+ -- for family instances
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifOpenSyn :: Bool, -- Is an open family?
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifOpenSyn :: Bool, -- Is an open family?
- ifSynRhs :: IfaceType -- Type for an ordinary
+ ifSynRhs :: IfaceType, -- Type for an ordinary
-- synonym and kind for an
-- open family
-- synonym and kind for an
-- open family
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ -- Just <=> instance of family
+ -- Invariant: ifOpenSyn == False
+ -- for family instances
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifOpenSyn = False, ifSynRhs = mono_ty})
+ ifOpenSyn = False, ifSynRhs = mono_ty,
+ ifFamInst = mbFamInst})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (equals <+> ppr mono_ty)
+ 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
-- The type variables of the data type do not scope
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
-- The type variables of the data type do not scope
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
- where
- Nothing `eqIfTc_fam` Nothing = Equal
- (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
- fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
- _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
+ ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
)
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
)
eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
eqWith = eq_ifTvBndrs emptyEqEnv
eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
eqWith = eq_ifTvBndrs emptyEqEnv
+eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
+ -> Maybe (IfaceTyCon, [IfaceType])
+ -> IfaceEq
+Nothing `eqIfTc_fam` Nothing = Equal
+(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
+ fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
+_ `eqIfTc_fam` _ = NotEqual
+
+
-----------------------
eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
-- All other changes are handled via the version info on the dfun
-----------------------
eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
-- All other changes are handled via the version info on the dfun
tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
- = IfaceSyn { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
+ = IfaceSyn { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
- ifSynRhs = toIfaceType syn_tyki }
+ ifSynRhs = toIfaceType syn_tyki,
+ ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
+ }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
tcIfaceDecl ignore_prags
(IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
tcIfaceDecl ignore_prags
(IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
+ ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
+ ifFamInst = mb_family})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_tyki <- tcIfaceType rdr_rhs_ty
; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
else SynonymTyCon rhs_tyki
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_tyki <- tcIfaceType rdr_rhs_ty
; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
else SynonymTyCon rhs_tyki
- -- !!!TODO: read mb_family info from iface and pass as last argument
- ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing
+ ; famInst <- case mb_family of
+ Nothing -> return Nothing
+ Just (fam, tys) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
+ ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
; return $ ATyCon tycon
}
; return $ ATyCon tycon
}