Commit e8a591c1 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Extended TyCon and friends to represent family declarations

Mon Sep 18 18:50:35 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Extended TyCon and friends to represent family declarations
  Tue Aug 15 16:52:31 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Extended TyCon and friends to represent family declarations
parent 202ac08f
......@@ -913,11 +913,12 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
put_ bh (IfaceSyn aq ar as) = do
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
put_ bh aq
put_ bh ar
put_ bh as
put_ bh at
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do
putByte bh 4
put_ bh a1
......@@ -947,7 +948,8 @@ instance Binary IfaceDecl where
aq <- get bh
ar <- get bh
as <- get bh
return (IfaceSyn aq ar as)
at <- get bh
return (IfaceSyn aq ar as at)
_ -> do
a1 <- get bh
a2 <- get bh
......@@ -983,15 +985,19 @@ instance Binary OverlapFlag where
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh (IfDataTyCon cs) = do { putByte bh 1
put_ bh IfOpenDataTyCon = putByte bh 1
put_ bh IfOpenNewTyCon = putByte bh 2
put_ bh (IfDataTyCon cs) = do { putByte bh 3
; put_ bh cs }
put_ bh (IfNewTyCon c) = do { putByte bh 2
put_ bh (IfNewTyCon c) = do { putByte bh 4
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> do cs <- get bh
1 -> return IfOpenDataTyCon
2 -> return IfOpenNewTyCon
3 -> do cs <- get bh
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
......
......@@ -6,7 +6,8 @@
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
mkNewTyConRhs, mkDataTyConRhs
) where
#include "HsVersions.h"
......@@ -26,14 +27,16 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
isRecursiveTyCon, tyConArity,
AlgTyConRhs(..), newTyConRhs )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
tyConStupidTheta, tyConDataCons, isNewTyCon,
mkClassTyCon, TyCon( tyConTyVars ),
isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
SynTyConRhs(..), newTyConRhs )
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
mkPredTys, mkTyVarTys, ThetaType, Type,
splitTyConApp_maybe, splitAppTy_maybe,
getTyVar_maybe,
mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
mkTyConApp, mkTyVarTy )
import Coercion ( mkNewTypeCoercion )
......@@ -45,8 +48,13 @@ import List ( nub )
\begin{code}
------------------------------------------------------
buildSynTyCon name tvs rhs_ty
= mkSynTyCon name kind tvs rhs_ty
buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
= mkSynTyCon name kind tvs rhs
where
kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
= mkSynTyCon name kind tvs rhs
where
kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
......@@ -72,6 +80,12 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
mkOpenDataTyConRhs :: AlgTyConRhs
mkOpenDataTyConRhs = OpenDataTyCon
mkOpenNewTyConRhs :: AlgTyConRhs
mkOpenNewTyConRhs = OpenNewTyCon
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
= DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
......
......@@ -81,9 +81,12 @@ data IfaceDecl
-- imported modules may have been compiled with
-- different flags to the current compilation unit
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifSynRhs :: IfaceType -- synonym expansion
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifOpenSyn :: Bool, -- Is an open family?
ifSynRhs :: IfaceType -- Type for an ordinary
-- synonym and kind for an
-- open family
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
......@@ -104,11 +107,15 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
data IfaceConDecls
= IfAbstractTyCon -- No info
| IfOpenDataTyCon -- Open data family
| IfOpenNewTyCon -- Open newtype family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls IfOpenDataTyCon = []
visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
......@@ -229,10 +236,16 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = False, ifSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (equals <+> ppr mono_ty)
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
= hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr mono_ty)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec})
......@@ -241,8 +254,10 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
IfOpenNewTyCon -> ptext SLIT("newtype family")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs, ifRec = isrec})
......@@ -262,7 +277,9 @@ pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
pp_condecls tc IfOpenNewTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
(map (pprIfaceConDecl tc) cs))
......@@ -556,6 +573,8 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
......
......@@ -185,7 +185,8 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
import NewDemand ( isTopSig )
import CoreSyn
import Class ( classExtraBigSig, classTyCon )
import TyCon ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
......@@ -1018,9 +1019,10 @@ tyThingToIfaceDecl ext (AClass clas)
tyThingToIfaceDecl ext (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = toIfaceType ext syn_ty }
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifOpenSyn = syn_isOpen,
ifSynRhs = toIfaceType ext syn_tyki }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
......@@ -1048,10 +1050,16 @@ tyThingToIfaceDecl ext (ATyCon tycon)
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
syn_ty = synTyConRhs tycon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
(syn_isOpen, syn_tyki) = case synTyConRhs tycon of
OpenSynTyCon ki -> (True , ki)
SynonymTyCon ty -> (False, ty)
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls OpenDataTyCon = IfOpenDataTyCon
ifaceConDecls OpenNewTyCon = IfOpenNewTyCon
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
......
......@@ -19,8 +19,10 @@ import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc,
newIfaceName, newIfaceNames, ifaceExportNames )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
mkAbstractTyConRhs, mkOpenDataTyConRhs,
mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
liftedTypeKindTyCon, unliftedTypeKindTyCon,
......@@ -28,7 +30,7 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
ubxTupleKindTyCon,
mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import TyCon ( TyCon, tyConName, SynTyConRhs(..) )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
......@@ -371,11 +373,13 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
}}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = rdr_rhs_ty})
ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_ty <- tcIfaceType rdr_rhs_ty
; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
; rhs_tyki <- tcIfaceType rdr_rhs_ty
; let rhs = if isOpen then OpenSynTyCon rhs_tyki
else SynonymTyCon rhs_tyki
; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
}
tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
......@@ -413,6 +417,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
IfOpenNewTyCon -> return mkOpenNewTyConRhs
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
......
......@@ -109,7 +109,8 @@ module GHC (
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
synTyConDefn, synTyConRhs,
isOpenTyCon,
synTyConDefn, synTyConType, synTyConResKind,
-- ** Type variables
TyVar,
......@@ -203,8 +204,9 @@ import Id ( Id, idType, isImplicitId, isDeadBinder,
import Var ( TyVar )
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon, tyConArity,
tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
tyConTyVars, tyConDataCons, synTyConDefn,
synTyConType, synTyConResKind )
import Class ( Class, classSCTheta, classTvsFds, classMethods )
import FunDeps ( pprFundeps )
import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
......
......@@ -67,7 +67,7 @@ pprTyThingHdr exts (ATyCon tyCon) = pprTyConHdr exts tyCon
pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls
pprTyConHdr exts tyCon =
ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars)
addFamily (ptext keyword) <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
vars | GHC.isPrimTyCon tyCon ||
GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
......@@ -77,6 +77,10 @@ pprTyConHdr exts tyCon =
| GHC.isNewTyCon tyCon = SLIT("newtype")
| otherwise = SLIT("data")
addFamily keytext
| GHC.isOpenTyCon tyCon = keytext <> ptext SLIT(" family")
| otherwise = keytext
pprDataConSig exts dataCon =
ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon)
......@@ -109,8 +113,12 @@ pprType False ty = ppr (GHC.dropForAlls ty)
pprTyCon exts tyCon
| GHC.isSynTyCon tyCon
= let rhs_type = GHC.synTyConRhs tyCon
in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
= if GHC.isOpenTyCon tyCon
then pprTyConHdr exts tyCon <+> dcolon <+>
pprType exts (GHC.synTyConResKind tyCon)
else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
| otherwise
= pprAlgTyCon exts tyCon (const True) (const True)
......
......@@ -35,6 +35,7 @@ import RdrHsSyn ( findSplice )
import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
import TyCon ( isOpenTyCon )
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
......
......@@ -585,9 +585,12 @@ reifyTyCon tc
| isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
= case synTyConDefn tc of
Nothing -> noTH SLIT("type family") (ppr tc)
Just (tvs, rhs) ->
do { rhs' <- reifyType rhs
; return (TH.TyConI $
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
......
......@@ -44,8 +44,11 @@ import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
)
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
OpenNewTyCon ),
SynTyConRhs( OpenSynTyCon, SynonymTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon,
isRecursiveTyCon, isOpenTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
isNewTyCon )
import DataCon ( DataCon, dataConUserType, dataConName,
......@@ -583,7 +586,7 @@ tcSynDecl
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "tcd1" <+> ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) }
; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) }
--------------------
tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing
......@@ -591,18 +594,38 @@ tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing
tcTyClDecl calc_isrec decl
= tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
-- kind signature for a type functions
-- kind signature for a type function
tcTyClDecl1 _calc_isrec
(TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
= tcKindSigDecl tc_name tvs kind
= tcTyVarBndrs tvs $ \ tvs' -> do
{ gla_exts <- doptM Opt_GlasgowExts
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
; return (ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind)))
}
-- kind signature for an indexed data type
tcTyClDecl1 _calc_isrec
(TyData {tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = Just kind, tcdCons = []})
= do
{ checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
; tcKindSigDecl tc_name tvs kind
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
; gla_exts <- doptM Opt_GlasgowExts
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
(case new_or_data of
DataType -> OpenDataTyCon
NewType -> OpenNewTyCon)
Recursive False True
; return (ATyCon tycon)
}
tcTyClDecl1 calc_isrec
......@@ -688,28 +711,6 @@ tcTyClDecl1 calc_isrec
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
= returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0))
-----------------------------------
tcKindSigDecl :: Name -> [LHsTyVarBndr Name] -> Kind -> TcM TyThing
tcKindSigDecl tc_name tvs kind
= tcTyVarBndrs tvs $ \ tvs' -> do
{ gla_exts <- doptM Opt_GlasgowExts
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
-- !!!TODO
-- We need to extend TyCon.TyCon with a new variant representing indexed
-- type constructors (ie, IdxTyCon). We will use them for both indexed
-- data types as well as type functions. In the case of indexed *data*
-- types, they are *abstract*; ie, won't be rewritten. OR do we just want
-- to make another variant of AlgTyCon (after all synonyms are also
-- AlgTyCons...)
-- We need an additional argument to this functions, which determines
-- whether the type constructor is abstract.
; tycon <- error "TcTyClsDecls.tcKindSigDecl: IdxTyCon not implemented yet."
; return (ATyCon tycon)
}
-----------------------------------
tcConDecl :: Bool -- True <=> -funbox-strict_fields
-> NewOrData -> TyCon -> [TyVar]
......@@ -887,7 +888,9 @@ checkValidTyCl decl
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| isSynTyCon tc
= checkValidType syn_ctxt syn_rhs
= case synTyConRhs tc of
OpenSynTyCon _ -> return ()
SynonymTyCon ty -> checkValidType syn_ctxt ty
| otherwise
= -- Check the context on the data decl
checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_`
......@@ -901,7 +904,6 @@ checkValidTyCon tc
where
syn_ctxt = TySynCtxt name
name = tyConName tc
syn_rhs = synTyConRhs tc
data_cons = tyConDataCons tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
......
......@@ -22,7 +22,7 @@ import RnHsSyn ( extractHsTyNames )
import Type ( predTypeRep, tcView )
import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
synTyConDefn, isSynTyCon, isAlgTyCon,
isSynTyCon, isAlgTyCon,
tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
......
......@@ -169,7 +169,8 @@ import Type ( -- Re-exports
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon,
synTyConDefn, tyConUnique )
import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
import Class ( Class )
import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
......@@ -591,8 +592,9 @@ isTauTy other = False
isTauTyCon :: TyCon -> Bool
-- Returns False for type synonyms whose expansion is a polytype
isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
| otherwise = True
isTauTyCon tc
| isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
| otherwise = True
---------------
isBoxyTy :: TcType -> Bool
......
......@@ -11,10 +11,11 @@ module TyCon(
tyConPrimRep,
AlgTyConRhs(..), visibleDataCons,
SynTyConRhs(..),
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
isHiBootTyCon, isSuperKindTyCon,
......@@ -46,7 +47,7 @@ module TyCon(
tyConStupidTheta,
tyConArity,
isClassTyCon, tyConClass_maybe,
synTyConDefn, synTyConRhs,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
maybeTyConSingleCon,
......@@ -93,10 +94,11 @@ data TyCon
tyConKind :: Kind,
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon
-- (b) the cached types in AlgTyConRhs.NewTyCon
tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta
-- (b) the cached types in
-- algTyConRhs.NewTyCon
-- But not over the data constructors
algTcSelIds :: [Id], -- Its record selectors (empty if none):
algTcSelIds :: [Id], -- Its record selectors (empty if none)
algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax
-- That doesn't mean it's a true GADT; only that the "where"
......@@ -107,8 +109,8 @@ data TyCon
algTcRhs :: AlgTyConRhs, -- Data constructors in here
algTcRec :: RecFlag, -- Tells whether the data type is part of
-- a mutually-recursive group or not
algTcRec :: RecFlag, -- Tells whether the data type is part
-- of a mutually-recursive group or not
hasGenerics :: Bool, -- True <=> generic to/from functions are available
-- (in the exports of the data type's source module)
......@@ -135,9 +137,7 @@ data TyCon
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
synTcRhs :: Type -- Right-hand side, mentioning these type vars.
-- Acts as a template for the expansion when
-- the tycon is applied to some types.
synTcRhs :: SynTyConRhs -- Expanded type in here
}
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
......@@ -183,6 +183,9 @@ data AlgTyConRhs
-- Used when we export a data type abstractly into
-- an hi file
| OpenDataTyCon -- data family (further instances can appear
| OpenNewTyCon -- newtype family at any time)
| DataTyCon {
data_cons :: [DataCon],
-- The constructors; can be empty if the user declares
......@@ -227,8 +230,16 @@ data AlgTyConRhs
visibleDataCons :: AlgTyConRhs -> [DataCon]
visibleDataCons AbstractTyCon = []
visibleDataCons OpenDataTyCon = []
visibleDataCons OpenNewTyCon = []
visibleDataCons (DataTyCon{ data_cons = cs }) = cs
visibleDataCons (NewTyCon{ data_con = c }) = [c]
data SynTyConRhs
= OpenSynTyCon Kind -- Type family: *result* kind given
| SynonymTyCon Type -- Mentioning head type vars. Acts as a template for
-- the expansion when the tycon is applied to some
-- types.
\end{code}
Note [Newtype coercions]
......@@ -507,7 +518,9 @@ isDataTyCon :: TyCon -> Bool
-- unboxed tuples
isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
= case rhs of
OpenDataTyCon -> True
DataTyCon {} -> True
OpenNewTyCon -> False
NewTyCon {} -> False
AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
......@@ -547,6 +560,12 @@ isEnumerationTyCon :: TyCon -> Bool
isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
isEnumerationTyCon other = False
isOpenTyCon :: TyCon -> Bool
isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True
isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True
isOpenTyCon _ = False
isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
-- but I thought that was silly so I've undone it
......@@ -610,7 +629,8 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe
[Type]) -- Leftover args
-- For the *typechecker* view, we expand synonyms only
tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys
tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs,
synTcRhs = SynonymTyCon rhs }) tys
= expand tvs rhs tys
tcExpandTyCon_maybe other_tycon tys = Nothing
......@@ -701,11 +721,22 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
\begin{code}
synTyConDefn :: TyCon -> ([TyVar], Type)
synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty)
synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty})
= (tyvars, ty)
synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon)
synTyConRhs :: TyCon -> Type
synTyConRhs tc = synTcRhs tc
synTyConRhs :: TyCon -> SynTyConRhs
synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs
synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc)
synTyConType :: TyCon -> Type
synTyConType tc = case synTcRhs tc of
SynonymTyCon t -> t
_ -> pprPanic "synTyConType" (ppr tc)
synTyConResKind :: TyCon -> Kind