Commit af5a2151 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-03-17 13:59:06 by simonpj]

------------------------
	More newtype clearing up
	------------------------

* Change the representation of TyCons so that it accurately reflects
	* data     (0 or more constrs)
	* newtype  (1 constr)
	* abstract (unknown)
  Replaces DataConDetails and AlgTyConFlavour with AlgTyConRhs

* Add IfaceSyn.IfaceConDecls, a kind of stripped-down analogue
  of AlgTyConRhs

* Move NewOrData from BasicTypes to HsDecl (it's now an HsSyn thing)

* Arrange that Type.newTypeRep and splitRecNewType_maybe unwrap just
  one layer of new-type-ness, leaving the caller to recurse.

  This still leaves typeRep and repType in Type.lhs; these functions
  are still vaguely disturbing and probably should get some attention.

Lots of knock-on changes.  Fixes bug in ds054.
parent a34e79f1
......@@ -27,8 +27,6 @@ module BasicTypes(
IPName(..), ipNameName, mapIPName,
NewOrData(..),
RecFlag(..), isRec, isNonRec, boolToRecFlag,
TopLevelFlag(..), isTopLevel, isNotTopLevel,
......@@ -191,24 +189,6 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
\end{code}
%************************************************************************
%* *
\subsection[NewType/DataType]{NewType/DataType flag}
%* *
%************************************************************************
\begin{code}
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
deriving( Eq ) -- Needed because Demand derives Eq
instance Outputable NewOrData where
ppr NewType = ptext SLIT("newtype")
ppr DataType = ptext SLIT("data")
\end{code}
%************************************************************************
%* *
\subsection[Top-level/local]{Top-level/not-top level flag}
......
......@@ -51,7 +51,7 @@ import CoreUtils ( exprType )
import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
import Maybe ( catMaybes )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( NewOrData(..), isBoxed )
import BasicTypes ( isBoxed )
import Packages ( thPackage )
import Outputable
import Bag ( bagToList )
......
......@@ -23,7 +23,7 @@ import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..),
noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc )
import Type ( Type )
import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) )
import BasicTypes( Boxity(..), RecFlag(Recursive) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..))
import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
......
......@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code}
module HsDecls (
HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl,
InstDecl(..), LInstDecl,
InstDecl(..), LInstDecl, NewOrData(..),
RuleDecl(..), LRuleDecl, RuleBndr(..),
DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
......@@ -38,7 +38,7 @@ import HsImpExp ( pprHsVar )
import HsTypes
import HscTypes ( DeprecTxt )
import CoreSyn ( RuleName )
import BasicTypes ( NewOrData(..), Activation(..) )
import BasicTypes ( Activation(..) )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
CExportSpec(..))
......@@ -323,6 +323,11 @@ data TyClDecl name
tcdSigs :: [LSig name], -- Methods' signatures
tcdMeths :: LHsBinds name -- Default methods
}
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
Simple classifiers
......@@ -431,6 +436,10 @@ pp_tydecl pp_head pp_decl_rhs derivings
Just ds -> hsep [ptext SLIT("deriving"),
ppr_hs_context (unLoc ds)]
])
instance Outputable NewOrData where
ppr NewType = ptext SLIT("newtype")
ppr DataType = ptext SLIT("data")
\end{code}
......
......@@ -17,7 +17,7 @@ module HsSyn (
module HsPat,
module HsTypes,
module HsUtils,
Fixity, NewOrData,
Fixity,
HsModule(..), HsExtCore(..)
) where
......@@ -33,7 +33,7 @@ import HsLit
import HsPat
import HsTypes
import HscTypes ( DeprecTxt )
import BasicTypes ( Fixity, NewOrData )
import BasicTypes ( Fixity )
import HsUtils
-- others:
......
......@@ -14,7 +14,6 @@ import BasicTypes
import NewDemand
import IfaceSyn
import VarEnv
import TyCon ( DataConDetails(..) )
import Class ( DefMeth(..) )
import CostCentre
import Module ( moduleName, mkModule )
......@@ -51,7 +50,6 @@ readBinIface hi_path = getBinFileWithDict hi_path
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for FixityDirection derive: Binary !-}
{-! for NewOrData derive: Binary !-}
{-! for Boxity derive: Binary !-}
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
......@@ -62,9 +60,6 @@ readBinIface hi_path = getBinFileWithDict hi_path
{-! for DmdResult derive: Binary !-}
{-! for StrictSig derive: Binary !-}
-- TyCon
{-! for DataConDetails derive: Binary !-}
-- Class
{-! for DefMeth derive: Binary !-}
......@@ -318,17 +313,6 @@ instance Binary TupCon where
ac <- get bh
return (TupCon ab ac)
instance Binary NewOrData where
put_ bh NewType = do
putByte bh 0
put_ bh DataType = do
putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> do return NewType
_ -> do return DataType
instance Binary RecFlag where
put_ bh Recursive = do
putByte bh 0
......@@ -891,7 +875,7 @@ instance Binary IfaceDecl where
put_ bh idinfo
put_ bh (IfaceForeign ae af) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh a1
put_ bh a2
......@@ -900,7 +884,6 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
......@@ -933,8 +916,7 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
a8 <- get bh
return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
return (IfaceData a1 a2 a3 a4 a5 a6 a7)
3 -> do
aq <- get bh
ar <- get bh
......@@ -959,6 +941,21 @@ instance Binary IfaceInst where
dfun <- get bh
return (IfaceInst ty dfun)
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh (IfDataTyCon cs) = do { putByte bh 1
; put_ bh cs }
put_ bh (IfNewTyCon c) = do { putByte bh 2
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> do aa <- get bh
return (IfDataTyCon aa)
_ -> do aa <- get bh
return (IfNewTyCon aa)
instance Binary IfaceConDecl where
put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
put_ bh a1
......@@ -1005,16 +1002,4 @@ instance Binary IfaceRule where
a6 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6)
instance (Binary datacon) => Binary (DataConDetails datacon) where
put_ bh (DataCons aa) = do
putByte bh 0
put_ bh aa
put_ bh Unknown = do
putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (DataCons aa)
_ -> do return Unknown
......@@ -6,7 +6,7 @@
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
newTyConRhs -- Just a useful little function with no obvious home
mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
) where
#include "HsVersions.h"
......@@ -18,10 +18,10 @@ import Subst ( substTyWith )
import Util ( zipLazy )
import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName )
import VarSet
import DataCon ( DataCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
import Var ( tyVarKind, TyVar )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
import Var ( tyVarKind, TyVar, Id )
import TysWiredIn ( unitTy )
import BasicTypes ( RecFlag, NewOrData( ..), StrictnessMark(..) )
import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
mkClassDataConOcc, mkSuperDictSelOcc )
......@@ -29,7 +29,7 @@ import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
ArgVrcs, DataConDetails( ..), AlgTyConFlavour(..) )
ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons )
import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind,
tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type )
import Outputable
......@@ -47,29 +47,40 @@ buildSynTyCon name tvs rhs_ty arg_vrcs
------------------------------------------------------
buildAlgTyCon :: NewOrData -> Name -> [TyVar] -> ThetaType
-> DataConDetails DataCon
buildAlgTyCon :: Name -> [TyVar] -> ThetaType
-> AlgTyConRhs
-> ArgVrcs -> RecFlag
-> Bool -- True <=> want generics functions
-> TcRnIf m n TyCon
buildAlgTyCon new_or_data tc_name tvs ctxt cons arg_vrcs is_rec want_generics
buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics
= do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs
cons sel_ids flavour is_rec want_generics
rhs sel_ids is_rec want_generics
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; sel_ids = mkRecordSelectors tycon cons
; flavour = case new_or_data of
NewType -> NewTyCon (mkNewTyConRep tycon)
DataType -> DataTyCon (all_nullary cons)
; sel_ids = mkRecordSelectors tycon rhs
}
; return tycon }
------------------------------------------------------
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
= DataTyCon cons (all is_nullary cons)
where
all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
all_nullary Unknown = False -- Safe choice for unknown data types
is_nullary con = null (dataConOrigArgTys con)
-- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
-- but that looks at the *representation* arity, and isEnumerationType
-- refers to the *source* code definition
mkNewTyConRhs :: DataCon -> AlgTyConRhs
mkNewTyConRhs con
= NewTyCon con -- The constructor
(head (dataConOrigArgTys con)) -- The RHS type
(mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type
------------------------------------------------------
buildDataCon :: Name
-> [StrictnessMark]
......@@ -117,6 +128,7 @@ thinContext arg_tys ctxt
tyVarsOfPred pred `intersectVarSet` arg_tyvars
------------------------------------------------------
mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id]
mkRecordSelectors tycon data_cons
= -- We'll check later that fields with the same name
-- from different constructors have the same type.
......@@ -126,48 +138,10 @@ mkRecordSelectors tycon data_cons
fields = [ field | con <- visibleDataCons data_cons,
field <- dataConFieldLabels con ]
eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
------------------------------------------------------
newTyConRhs :: TyCon -> Type -- The defn of a newtype, as written by the programmer
newTyConRhs tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
mkNewTyConRep :: TyCon -- The original type constructor
-> Type -- Chosen representation type
-- (guaranteed not to be another newtype)
-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
-- type, looking through other newtypes.
--
-- The non-recursive newtypes are easy, because they look transparent
-- to splitTyConApp_maybe, but recursive ones really are represented as
-- TyConApps (see TypeRep).
--
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
mkNewTyConRep tc
| null (tyConDataCons tc) = unitTy
-- External Core programs can have newtypes with no data constructors
| otherwise = go [] tc
where
-- Invariant: tc is a NewTyCon
-- tcs have been seen before
go tcs tc
| tc `elem` tcs = unitTy
| otherwise
= case splitTyConApp_maybe rep_ty of
Nothing -> rep_ty
Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
| otherwise -> go1 (tc:tcs) tc' tys
where
rep_ty = newTyConRhs tc
go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
\end{code}
------------------------------------------------------
\begin{code}
buildClass :: Name -> [TyVar] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
......@@ -214,8 +188,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs
tycon
; tycon = mkClassTyCon tycon_name clas_kind tvs
tc_vrcs dict_con
clas flavour tc_isrec
tc_vrcs rhs clas tc_isrec
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
......@@ -226,12 +199,48 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs
; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; flavour = case dict_component_tys of
[rep_ty] -> NewTyCon (mkNewTyConRep tycon)
other -> DataTyCon False -- Not an enumeration
; rhs = case dict_component_tys of
[rep_ty] -> mkNewTyConRhs dict_con
other -> mkDataTyConRhs [dict_con]
}
; return clas
})}
\end{code}
------------------------------------------------------
\begin{code}
mkNewTyConRep :: TyCon -- The original type constructor
-> Type -- Chosen representation type
-- (guaranteed not to be another newtype)
-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
-- type, looking through other newtypes.
--
-- The non-recursive newtypes are easy, because they look transparent
-- to splitTyConApp_maybe, but recursive ones really are represented as
-- TyConApps (see TypeRep).
--
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
mkNewTyConRep tc
| null (tyConDataCons tc) = unitTy
-- External Core programs can have newtypes with no data constructors
| otherwise = go [] tc
where
-- Invariant: tc is a NewTyCon
-- tcs have been seen before
go tcs tc
| tc `elem` tcs = unitTy
| otherwise
= case splitTyConApp_maybe rep_ty of
Nothing -> rep_ty
Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
| otherwise -> go1 (tc:tcs) tc' tys
where
(_,rep_ty) = newTyConRhs tc
go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
\end{code}
......@@ -14,11 +14,14 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
module IfaceSyn (
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
-- Misc
visibleIfConDecls,
-- Converting things to IfaceSyn
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
......@@ -46,11 +49,11 @@ import NewDemand ( isTopSig )
import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
arityInfo, cafInfo, newStrictnessInfo,
workerInfo, unfoldingInfo, inlinePragInfo )
import TyCon ( TyCon, ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity,
tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName )
tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
......@@ -64,7 +67,7 @@ import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
import TysPrim ( alphaTyVars )
import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..),
import BasicTypes ( Arity, Activation(..), StrictnessMark,
RecFlag(..), boolToRecFlag, Boxity(..),
tupleParens )
import Outputable
......@@ -89,11 +92,10 @@ data IfaceDecl
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifND :: NewOrData,
ifCtxt :: IfaceContext, -- Context
| IfaceData { ifCtxt :: IfaceContext, -- Context
ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCons :: DataConDetails IfaceConDecl,
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
ifVrcs :: ArgVrcs,
ifGeneric :: Bool -- True <=> generic converter functions available
......@@ -124,6 +126,16 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
data IfaceConDecls
= IfAbstractTyCon -- No info
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
data IfaceConDecl
= IfaceConDecl OccName -- Constructor name
[IfaceTvBndr] -- Existental tyvars
......@@ -246,10 +258,15 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, i
4 (vcat [equals <+> ppr mono_ty,
pprVrcs vrcs])
pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, ifGeneric = gen,
pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen,
ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
= hang (ppr new_or_data <+> pp_decl_head context tycon tyvars)
= hang (pp_nd <+> pp_decl_head context tycon tyvars)
4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
......@@ -270,8 +287,9 @@ pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pp_decl_head context thing tyvars
= hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
pp_condecls Unknown = ptext SLIT("{- abstract -}")
pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}")
pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
pp_condecls (IfNewTyCon c) = equals <+> ppr c
instance Outputable IfaceConDecl where
ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
......@@ -445,11 +463,10 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
ifSynRhs = toIfaceType ext syn_ty }
| isAlgTyCon tycon
= IfaceData { ifND = new_or_data,
ifCtxt = toIfaceContext ext (tyConTheta tycon),
= IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon),
ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifCons = ifaceConDecls (tyConDataConDetails tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifVrcs = tyConArgVrcs tycon,
ifGeneric = tyConHasGenerics tycon }
......@@ -460,11 +477,10 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
| isPrimTyCon tycon || isFunTyCon tycon
-- Needed in GHCi for ':info Int#', for example
= IfaceData { ifND = DataType,
ifCtxt = [],
= IfaceData { ifCtxt = [],
ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
ifCons = Unknown,
ifCons = IfAbstractTyCon,
ifGeneric = False,
ifRec = NonRecursive,
ifVrcs = tyConArgVrcs tycon }
......@@ -473,14 +489,13 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
where
tyvars = tyConTyVars tycon
(_, syn_ty) = getSynTyConDefn tycon
new_or_data | isNewTyCon tycon = NewType
| otherwise = DataType
abstract = getName tycon `elemNameSet` abstract_tcs
abstract = getName tycon `elemNameSet` abstract_tcs
ifaceConDecls _ | abstract = Unknown
ifaceConDecls Unknown = Unknown
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
ifaceConDecls _ | abstract = IfAbstractTyCon
ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls AbstractTyCon = pprPanic "ifaceConDecls" (ppr tycon)
-- We're exporting this thing, so it's locally defined and should not be abstract
ifaceConDecl data_con
= IfaceConDecl (getOccName (dataConName data_con))
......@@ -723,7 +738,6 @@ eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
= bool (ifName d1 == ifName d2 &&
ifND d1 == ifND d2 &&
ifRec d1 == ifRec d2 &&
ifVrcs d1 == ifVrcs d2 &&
ifGeneric d1 == ifGeneric d2) &&&
......@@ -769,9 +783,10 @@ eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
eq_ifaceExpr env rhs1 rhs2)
eqIfRule _ _ = NotEqual
eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
eq_hsCD env Unknown Unknown = Equal
eq_hsCD env d1 d2 = NotEqual
eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
(IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
......
......@@ -20,9 +20,9 @@ import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas
opt_InPackage )
import Parser ( parseIface )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..),
IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..),
IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
ExternalPackageState(..), emptyTypeEnv, emptyPool,
......@@ -55,7 +55,7 @@ import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc,
mkDataConWrapperOcc, mkDataConWorkerOcc )
import Class ( Class, className )
import TyCon ( DataConDetails(..), tyConName )
import TyCon ( tyConName )
import SrcLoc ( mkSrcLoc, importedSrcLoc )
import Maybes ( isJust, mapCatMaybes )
import StringBuffer ( hGetStringBuffer )
......@@ -300,11 +300,9 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs
tc_occ = mkClassTyConOcc cls_occ
dc_occ = mkClassDataConOcc cls_occ
ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = []
ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons})
= foldr ((++) . conDeclBndrs) [] cons
ifaceDeclSubBndrs other = []
ifaceDeclSubBndrs (IfaceData {ifCons = cons}) = foldr ((++) . conDeclBndrs) []
(visibleIfConDecls cons)
ifaceDeclSubBndrs other = []
conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
= fields ++
......
......@@ -177,7 +177,7 @@ import HsSyn
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..),
eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
eqMaybeBy, eqListBy,
eqMaybeBy, eqListBy, visibleIfConDecls,
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule )
import LoadIface ( readIface, loadInterface, ifaceInstGates )
import BasicTypes ( Version, initialVersion, bumpVersion )
......@@ -535,7 +535,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers,
eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
= same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons]
eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleIfConDecls cons]
eq_indirects other = Equal -- Synonyms and foreign declarations
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
......
......@@ -18,7 +18,8 @@ import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig,
tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,