IPName(..), ipNameName, mapIPName,
- NewOrData(..),
-
RecFlag(..), isRec, isNonRec, boolToRecFlag,
TopLevelFlag(..), isTopLevel, isNotTopLevel,
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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 )
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(..),
\begin{code}
module HsDecls (
HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl,
- InstDecl(..), LInstDecl,
+ InstDecl(..), LInstDecl, NewOrData(..),
RuleDecl(..), LRuleDecl, RuleBndr(..),
DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
import HsTypes
import HscTypes ( DeprecTxt )
import CoreSyn ( RuleName )
-import BasicTypes ( NewOrData(..), Activation(..) )
+import BasicTypes ( Activation(..) )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
CExportSpec(..))
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
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}
module HsPat,
module HsTypes,
module HsUtils,
- Fixity, NewOrData,
+ Fixity,
HsModule(..), HsExtCore(..)
) where
import HsPat
import HsTypes
import HscTypes ( DeprecTxt )
-import BasicTypes ( Fixity, NewOrData )
+import BasicTypes ( Fixity )
import HsUtils
-- others:
import NewDemand
import IfaceSyn
import VarEnv
-import TyCon ( DataConDetails(..) )
import Class ( DefMeth(..) )
import CostCentre
import Module ( moduleName, mkModule )
{-! 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 !-}
{-! for DmdResult derive: Binary !-}
{-! for StrictSig derive: Binary !-}
--- TyCon
-{-! for DataConDetails derive: Binary !-}
-
-- Class
{-! for DefMeth derive: Binary !-}
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
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
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh a8
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
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
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
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
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
- newTyConRhs -- Just a useful little function with no obvious home
+ mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
) where
#include "HsVersions.h"
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 )
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
------------------------------------------------------
-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]
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.
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
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 }
; 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}
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,
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 )
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
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
-- 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
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})
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)
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 }
| 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 }
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))
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) &&&
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)
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,
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 )
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 ++
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 )
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
tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
tcIfaceDataCon, tcIfaceLclId,
newIfaceName, newIfaceNames )
-import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
+ mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp,
mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
setArityInfo, setInlinePragInfo, setCafInfo,
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
-import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
+import TyCon ( AlgTyConRhs(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
import TysWiredIn ( tupleCon )
import Var ( TyVar, mkTyVar, tyVarKind )
; info <- tcIdInfo name ty info
; return (AnId (mkVanillaGlobal name ty info)) }
-tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name,
+tcIfaceDecl (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
; tycon <- fixM ( \ tycon -> do
{ cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
- ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons
+ ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons
arg_vrcs is_rec want_generic
; return tycon
})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0 [])) }
-tcIfaceDataCons tycon tyvars ctxt Unknown
- = returnM Unknown
-
-tcIfaceDataCons tycon tyvars ctxt (DataCons cs)
- = mappM tc_con_decl cs `thenM` \ data_cons ->
- returnM (DataCons data_cons)
+tcIfaceDataCons tycon tyvars ctxt if_cons
+ = case if_cons of
+ IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; return (mkNewTyConRhs data_con) }
where
tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
= bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
-- we call loadImportedInsts when looking up even predicates like (C a)
-- But without undecidable instances it's rare to see C (a b) and
-- somethat interesting
+{- (comment out; happens a lot in some code)
#ifdef DEBUG
; dflags <- getDOpts
; WARN( not (dopt Opt_AllowUndecidableInstances dflags) && null tc_gates,
<+> pprClassPred cls tys )
return ()
#endif
-
+-}
-- Suck in the instances
; let { (inst_pool', iface_insts)
= selectInsts (eps_insts eps) cls_gate tc_gates }
import CmdLineOpts ( opt_SccProfilingOn )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- NewOrData(..), Activation(..) )
+ Activation(..) )
import OrdList
import Bag ( emptyBag )
import Panic
import HsSyn -- Lots of it
import IfaceType
import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
-import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..) )
+import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace, rdrNameModule )
import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
occNameUserString, isValOcc )
import BasicTypes ( initialVersion, StrictnessMark(..) )
-import TyCon ( DataConDetails(..) )
import Module ( ModuleName )
import SrcLoc
import CStrings ( CLabelString )
ifVrcs = [] }
hsIfaceDecl (TyClD decl@(TyData {}))
- = IfaceData { ifND = tcdND decl,
- ifName = rdrNameOcc (tcdName decl),
+ = IfaceData { ifName = rdrNameOcc (tcdName decl),
ifTyVars = hsIfaceTvs (tcdTyVars decl),
ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifCons = hsIfaceCons (tcdCons decl),
+ ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
ifRec = NonRecursive,
ifVrcs = [], ifGeneric = False }
-- I'm not sure that [] is right for ifVrcs, but
hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
-hsIfaceCons :: [LConDecl RdrName] -> DataConDetails IfaceConDecl
-hsIfaceCons cons
- | null cons -- data T a, meaning "constructors unspecified", not "no constructors"
- = Unknown
- | otherwise -- data T a = C1 | C2
- = DataCons (map (hsIfaceCon . unLoc) cons)
+hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
+hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
+ = IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons DataType cons -- data type
+ = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
+
+hsIfaceCons NewType [con] -- newtype
+ = IfNewTyCon (hsIfaceCon (unLoc con))
+
hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
import OccName ( mkOccFS, tcName, dataName, mkTupleOcc, mkDataConWorkerOcc )
import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind )
-import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
+import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName
)
tyvars
[] -- No context
argvrcs
- (DataCons cons)
+ (DataTyCon cons is_enum)
[] -- No record selectors
- (DataTyCon is_enum)
is_rec
True -- All the wired-in tycons have generics
#include "HsVersions.h"
import HsSyn
-import BasicTypes ( RecFlag(..), NewOrData(..) )
+import BasicTypes ( RecFlag(..) )
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
import TcRnMonad ( thenM, returnM, mapAndUnzipM )
import HscTypes ( DFunId, FixityEnv )
-import BasicTypes ( NewOrData(..) )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
import Subst ( mkTyVarSubst, substTheta )
import ErrUtils ( dumpIfSet_dyn )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
import LoadIface ( loadSrcInterface )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..),
+import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
+ IfaceExtName(..), IfaceConDecls(..),
tyThingToIfaceDecl )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId )
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
= decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = DataCons cons})
- = decl { ifCons = DataCons (filter (keep_con occs) cons) }
+filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
+ = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
+filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
+ | keep_con occs con = decl
+ | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
filter_decl occs decl
= decl
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
- ConDecl(..), Sig(..), BangType(..), HsBang(..),
+ ConDecl(..), Sig(..), BangType(..), HsBang(..), NewOrData(..),
tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl,
LTyClDecl, tcdName, LHsTyVarBndr
)
-import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
+import BasicTypes ( RecFlag(..), StrictnessMark(..) )
import HscTypes ( implicitTyThings )
-import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon )
+import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
+ mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import TcEnv ( TcTyThing(..), TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
import FieldLabel ( fieldLabelName, fieldLabelType )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
-import TyCon ( TyCon, ArgVrcs, DataConDetails(..),
+import TyCon ( TyCon, ArgVrcs,
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
{ ctxt' <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
; tycon <- fixM (\ tycon -> do
- { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
- ; buildAlgTyCon new_or_data tc_name tvs' ctxt'
- (DataCons cons') arg_vrcs is_rec
- (want_generic && canDoGenerics cons')
+ { data_cons <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
+ ; let tc_rhs = case new_or_data of
+ DataType -> mkDataTyConRhs data_cons
+ NewType -> ASSERT( isSingleton data_cons )
+ mkNewTyConRhs (head data_cons)
+ ; buildAlgTyCon tc_name tvs' ctxt'
+ tc_rhs arg_vrcs is_rec
+ (want_generic && canDoGenerics data_cons)
})
; return (ATyCon tycon)
}
module TcTyDecls(
calcTyConArgVrcs,
calcRecFlags,
- calcClassCycles, calcSynCycles,
- newTyConRhs
+ calcClassCycles, calcSynCycles
) where
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
import RnHsSyn ( extractHsTyNames )
import Type ( predTypeRep )
-import BuildTyCl ( newTyConRhs )
import HscTypes ( TyThing(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
- tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
+ tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConRepArgTys, dataConOrigArgTys )
import Var ( TyVar )
nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
mk_nt_edges nt -- Invariant: nt is a newtype
- = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
+ = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
-- tyConsOfType looks through synonyms
mk_nt_edges1 nt tc
| tc `elem` prod_tycons = [tc] -- Local product
| tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
then []
- else mk_prod_edges1 ptc (newTyConRhs tc)
+ else mk_prod_edges1 ptc (new_tc_rhs tc)
| isHiBootTyCon tc = [ptc] -- Make it self-recursive if
-- it mentions an hi-boot TyCon
-- At this point we know that either it's a local non-product data type,
-- or it's imported. Either way, it can't form part of a cycle
| otherwise = []
+new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
+
getTyCon (ATyCon tc) = tc
getTyCon (AClass cl) = classTyCon cl
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- Look through newtypes
-- Non-recursive ones are transparent to splitTyConApp,
- -- but recursive ones aren't
+ -- but recursive ones aren't. Manuel had:
+ -- newtype T = MkT (Ptr T)
+ -- and wanted it to work...
checkRepTyCon check_tc ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
| otherwise = False
module TyCon(
TyCon, ArgVrcs,
- AlgTyConFlavour(..),
- DataConDetails(..), visibleDataCons,
+ AlgTyConRhs(..), visibleDataCons,
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
- isRecursiveTyCon, newTyConRep, isHiBootTyCon,
+ isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon,
mkForeignTyCon, isForeignTyCon,
tyConUnique,
tyConTyVars,
tyConArgVrcs,
- tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
+ algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
tyConSelIds,
tyConTheta,
tyConPrimRep,
}
- | AlgTyCon { -- Tuples, data type, and newtype decls.
+ | AlgTyCon { -- Data type, and newtype decls.
-- All lifted, all boxed
tyConUnique :: Unique,
tyConName :: Name,
argVrcs :: ArgVrcs,
algTyConTheta :: [PredType],
- dataCons :: DataConDetails DataCon,
+ selIds :: [Id], -- Its record selectors (if any)
- selIds :: [Id], -- Its record selectors (if any)
+ algTyConRhs :: AlgTyConRhs, -- Data constructors in here
- algTyConFlavour :: AlgTyConFlavour,
- algTyConRec :: RecFlag, -- Tells whether the data type is part of
+ algTyConRec :: RecFlag, -- Tells whether the data type is part of
-- a mutually-recursive group or not
- hasGenerics :: Bool, -- True <=> generic to/from functions are available
+ hasGenerics :: Bool, -- True <=> generic to/from functions are available
-- (in the exports of the data type's source module)
algTyConClass :: Maybe Class
primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are
-- boxed (represented by pointers). The PrimRep tells.
- isUnLifted :: Bool, -- Most primitive tycons are unlifted,
- -- but foreign-imported ones may not be
+ isUnLifted :: Bool, -- Most primitive tycons are unlifted,
+ -- but foreign-imported ones may not be
tyConExtName :: Maybe FastString -- Just xx for foreign-imported types
}
type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)]
-- [] means "no information, assume the worst"
-data AlgTyConFlavour
- = DataTyCon Bool -- Data type; True <=> an enumeration type
+data AlgTyConRhs
+ = AbstractTyCon -- We know nothing about this data type, except
+ -- that it's represented by a pointer
+ -- Used when we export a data type abstractly into
+ -- an hi file
- | NewTyCon Type -- Newtype, with its *ultimate* representation type
+ | DataTyCon
+ [DataCon] -- The constructors; can be empty if the user declares
+ -- the type to have no constructors
+ Bool -- Cached: True <=> an enumeration type
+
+ | NewTyCon -- Newtypes always have exactly one constructor
+ DataCon -- The unique constructor; it has no existentials
+ Type -- Cached: the argument type of the constructor
+ -- = the representation type of the tycon
+
+ Type -- Cached: the *ultimate* representation type
-- By 'ultimate' I mean that the rep type is not itself
-- a newtype or type synonym.
-- The rep type isn't entirely simple:
-- The rep type is [(a,Int)]
-- NB: the rep type isn't necessarily the original RHS of the
-- newtype decl, because the rep type looks through other
- -- newtypes. If you want hte original RHS, look at the
- -- argument type of the data constructor.
-
-data DataConDetails datacon
- = DataCons [datacon] -- Its data constructors, with fully polymorphic types
- -- A type can have zero constructors
-
- | Unknown -- Used only when We're importing this data type from an
- -- hi-boot file, so we don't know what its constructors are
+ -- newtypes.
-visibleDataCons (DataCons cs) = cs
-visibleDataCons other = []
+visibleDataCons :: AlgTyConRhs -> [DataCon]
+visibleDataCons AbstractTyCon = []
+visibleDataCons (DataTyCon cs _) = cs
+visibleDataCons (NewTyCon c _ _) = [c]
\end{code}
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec gen_info
+mkAlgTyCon name kind tyvars theta argvrcs rhs sels is_rec gen_info
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConTyVars = tyvars,
argVrcs = argvrcs,
algTyConTheta = theta,
- dataCons = cons,
+ algTyConRhs = rhs,
selIds = sels,
algTyConClass = Nothing,
- algTyConFlavour = flavour,
algTyConRec = is_rec,
hasGenerics = gen_info
}
-mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec
+mkClassTyCon name kind tyvars argvrcs rhs clas is_rec
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConTyVars = tyvars,
argVrcs = argvrcs,
algTyConTheta = [],
- dataCons = DataCons [con],
+ algTyConRhs = rhs,
selIds = [],
algTyConClass = Just clas,
- algTyConFlavour = flavour,
algTyConRec = is_rec,
hasGenerics = False
}
isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity)
isUnLiftedTyCon _ = False
-#ifdef UNUSED
--- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
-isBoxedTyCon :: TyCon -> Bool
-isBoxedTyCon (AlgTyCon {}) = True
-isBoxedTyCon (FunTyCon {}) = True
-isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
-isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep
-#endif
-
-- isAlgTyCon returns True for both @data@ and @newtype@
isAlgTyCon :: TyCon -> Bool
isAlgTyCon (AlgTyCon {}) = True
-- True for all @data@ types
-- False for newtypes
-- unboxed tuples
-isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data})
- = case new_or_data of
- NewTyCon _ -> False
- other -> True
+isDataTyCon (AlgTyCon {algTyConRhs = rhs})
+ = case rhs of
+ DataTyCon _ _ -> True
+ NewTyCon _ _ _ -> False
+ AbstractTyCon -> panic "isDataTyCon"
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True
+isNewTyCon (AlgTyCon {algTyConRhs = NewTyCon _ _ _}) = True
isNewTyCon other = False
isProductTyCon :: TyCon -> Bool
-- may be DataType or NewType,
-- may be unboxed or not,
-- may be recursive or not
-isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialDataCon data_con)
-isProductTyCon (TupleTyCon {}) = True
-isProductTyCon other = False
+isProductTyCon tc@(AlgTyCon {}) = case algTyConRhs tc of
+ DataTyCon [data_con] _ -> not (isExistentialDataCon data_con)
+ NewTyCon _ _ _ -> True
+ other -> False
+isProductTyCon (TupleTyCon {}) = True
+isProductTyCon other = False
isSynTyCon :: TyCon -> Bool
isSynTyCon (SynTyCon {}) = True
isSynTyCon _ = False
isEnumerationTyCon :: TyCon -> Bool
-isEnumerationTyCon (AlgTyCon {algTyConFlavour = DataTyCon is_enum}) = is_enum
-isEnumerationTyCon other = False
+isEnumerationTyCon (AlgTyCon {algTyConRhs = DataTyCon _ is_enum}) = is_enum
+isEnumerationTyCon other = False
isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
isHiBootTyCon :: TyCon -> Bool
-- Used for knot-tying in hi-boot files
-isHiBootTyCon (AlgTyCon {dataCons = Unknown}) = True
-isHiBootTyCon other = False
+isHiBootTyCon (AlgTyCon {algTyConRhs = AbstractTyCon}) = True
+isHiBootTyCon other = False
isForeignTyCon :: TyCon -> Bool
-- isForeignTyCon identifies foreign-imported type constructors
tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
tyConHasGenerics other = False -- Synonyms
-tyConDataConDetails :: TyCon -> DataConDetails DataCon
-tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons
-tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con]
-tyConDataConDetails other = pprPanic "tyConDataConDetails" (ppr other)
-
tyConDataCons :: TyCon -> [DataCon]
-- It's convenient for tyConDataCons to return the
-- empty list for type synonyms etc
tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []
tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
-tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons
-tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con]
-tyConDataCons_maybe other = Nothing
+tyConDataCons_maybe (AlgTyCon {algTyConRhs = DataTyCon cons _}) = Just cons
+tyConDataCons_maybe (AlgTyCon {algTyConRhs = NewTyCon con _ _}) = Just [con]
+tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con]
+tyConDataCons_maybe other = Nothing
tyConFamilySize :: TyCon -> Int
-tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs
-tyConFamilySize (TupleTyCon {}) = 1
+tyConFamilySize (AlgTyCon {algTyConRhs = DataTyCon cons _}) = length cons
+tyConFamilySize (AlgTyCon {algTyConRhs = NewTyCon _ _ _}) = 1
+tyConFamilySize (TupleTyCon {}) = 1
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
\begin{code}
newTyConRep :: TyCon -> ([TyVar], Type)
-newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep)
+newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConRhs = NewTyCon _ _ rep}) = (tvs, rep)
+
+newTyConRhs :: TyCon -> ([TyVar], Type)
+newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTyConRhs = NewTyCon _ rhs _}) = (tvs, rhs)
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
\begin{code}
maybeTyConSingleCon :: TyCon -> Maybe DataCon
-maybeTyConSingleCon (AlgTyCon {dataCons = DataCons [c]}) = Just c
-maybeTyConSingleCon (AlgTyCon {}) = Nothing
-maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
-maybeTyConSingleCon (PrimTyCon {}) = Nothing
-maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty
+maybeTyConSingleCon (AlgTyCon {algTyConRhs = DataTyCon [c] _}) = Just c
+maybeTyConSingleCon (AlgTyCon {algTyConRhs = NewTyCon c _ _}) = Just c
+maybeTyConSingleCon (AlgTyCon {}) = Nothing
+maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
+maybeTyConSingleCon (PrimTyCon {}) = Nothing
+maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty
maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc
\end{code}
import Class ( Class, classTyCon )
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isNewTyCon, newTyConRep,
+ isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
isAlgTyCon, isSynTyCon, tyConArity,
- tyConKind, getSynTyConDefn,
+ tyConKind, getSynTyConDefn,
tyConPrimRep,
)
AppTy _ _ -> PtrRep -- ??
TyVarTy _ -> PtrRep
other -> pprPanic "typePrimRep" (ppr ty)
+
+-- new_type_rep doesn't ask any questions:
+-- it just expands newtype, whether recursive or not
+new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
+ case newTyConRep new_tycon of
+ (tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
predTypeRep :: PredType -> Type
-- Convert a PredType to its "representation type";
-- the post-type-checking type used by all the Core passes of GHC.
+-- Unwraps only the outermost level; for example, the result might
+-- be a NewTcApp; c.f. newTypeRep
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a NewTcApp, but the consumer will
splitRecNewType_maybe :: Type -> Maybe Type
-- Newtypes are always represented by a NewTcApp
-- Sometimes we want to look through a recursive newtype, and that's what happens here
+-- It only strips *one layer* off, so the caller will usually call itself recursively
-- Only applied to types of kind *, hence the newtype is always saturated
splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty
splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p)
splitRecNewType_maybe (NewTcApp tc tys)
| isRecursiveTyCon tc
= ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc )
- -- The assert should hold because repType should
- -- only be applied to *types* (of kind *)
- Just (new_type_rep tc tys)
+ -- The assert should hold because splitRecNewType_maybe
+ -- should only be applied to *types* (of kind *)
+ Just (new_type_rhs tc tys)
splitRecNewType_maybe other = Nothing
-----------------------------
newTypeRep :: TyCon -> [Type] -> Type
-- A local helper function (not exported)
--- Expands a newtype application to
+-- Expands *the outermoset level of* a newtype application to
-- *either* a vanilla TyConApp (recursive newtype, or non-saturated)
--- *or* the newtype representation (otherwise)
--- Either way, the result is not a NewTcApp
+-- *or* the newtype representation (otherwise), meaning the
+-- type written in the RHS of the newtype decl,
+-- which may itself be a newtype
+--
+-- Example: newtype R = MkR S
+-- newtype S = MkS T
+-- newtype T = MkT (T -> T)
+-- newTypeRep on R gives NewTcApp S
+-- on S gives NewTcApp T
+-- on T gives TyConApp T
--
-- NB: the returned TyConApp is always deconstructed immediately by the
-- caller... a TyConApp with a newtype type constructor never lives
newTypeRep tc tys
| not (isRecursiveTyCon tc), -- Not recursive and saturated
tys `lengthIs` tyConArity tc -- treat as equivalent to expansion
- = new_type_rep tc tys
+ = new_type_rhs tc tys
| otherwise
= TyConApp tc tys
-- ToDo: Consider caching this substitution in a NType
-----------------------------
--- new_type_rep doesn't ask any questions:
--- it just expands newtype, whether recursive or not
-new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
- case newTyConRep new_tycon of
- (tvs, rep_ty) -> substTyWith tvs tys rep_ty
+-- new_type_rhs doesn't ask any questions:
+-- it just expands newtype one level, whether recursive or not
+new_type_rhs tc tys
+ = case newTyConRhs tc of
+ (tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
projects / ghc-hetmet.git / commitdiff