From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:35:34 +0000 (+0000) Subject: Extend TyCons and DataCons to represent data instance decls X-Git-Tag: After_FC_branch_merge~31 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=80c89b80c355b2aaebcd53330e6c6170c3f05aca Extend TyCons and DataCons to represent data instance decls Mon Sep 18 19:05:18 EDT 2006 Manuel M T Chakravarty * Extend TyCons and DataCons to represent data instance decls Fri Aug 18 19:11:37 EDT 2006 Manuel M T Chakravarty * Extend TyCons and DataCons to represent data instance decls - This is a faily involved patch, but it is not entirely complete: + The data con wrapper code for instance data cons needs to apply the coercions (which we still have to generate). + There are still bugs, but it doesn't seem to affect the compilation of code that doesn't use type families. ** WARNING: Yet another change of the iface format. ** ** Recompile everything. ** --- diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index f873977..a04f28f 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -11,6 +11,7 @@ module DataCon ( dataConRepType, dataConSig, dataConFullSig, dataConName, dataConTag, dataConTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, + dataConInstTys, dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConInstOrigArgTys, dataConRepArgTys, @@ -38,7 +39,7 @@ import Type ( Type, ThetaType, import Coercion ( isEqPred, mkEqPred ) import TyCon ( TyCon, FieldLabel, tyConDataCons, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isNewTyCon, isRecursiveTyCon ) + isNewTyCon, isRecursiveTyCon, tyConFamily_maybe ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName ) import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique, @@ -335,9 +336,13 @@ data DataCon -- An entirely separate wrapper function is built in TcTyDecls dcIds :: DataConIds, - dcInfix :: Bool -- True <=> declared infix + dcInfix :: Bool, -- True <=> declared infix -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere + + dcInstTys :: Maybe [Type] -- If this data constructor is part of a + -- data instance, then these are the type + -- patterns of the instance. } data DataConIds @@ -433,6 +438,7 @@ mkDataCon :: Name -> [TyVar] -> [TyVar] -> [(TyVar,Type)] -> ThetaType -> [Type] -> TyCon + -> Maybe [Type] -> ThetaType -> DataConIds -> DataCon -- Can get the tag from the TyCon @@ -443,6 +449,7 @@ mkDataCon name declared_infix univ_tvs ex_tvs eq_spec theta orig_arg_tys tycon + mb_typats stupid_theta ids = ASSERT( not (any isEqPred theta) ) -- We don't currently allow any equality predicates on @@ -459,9 +466,11 @@ mkDataCon name declared_infix dcStupidTheta = stupid_theta, dcTheta = theta, dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcRepArgTys = rep_arg_tys, - dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, + dcStrictMarks = arg_stricts, + dcRepStrictness = rep_arg_stricts, dcFields = fields, dcTag = tag, dcRepType = ty, - dcIds = ids } + dcIds = ids, + dcInstTys = mb_typats } -- Strictness marks for source-args -- *after unboxing choices*, @@ -600,20 +609,32 @@ dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc] where env = mkTopTvSubst (dcEqSpec dc) +dataConInstTys :: DataCon -> Maybe [Type] +dataConInstTys = dcInstTys + dataConUserType :: DataCon -> Type -- The user-declared type of the data constructor -- in the nice-to-read form -- T :: forall a. a -> T [a] -- rather than -- T :: forall b. forall a. (a=[b]) => a -> T b +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcTheta = theta, dcOrigArgTys = arg_tys, - dcTyCon = tycon }) + dcTyCon = tycon, dcInstTys = mb_insttys }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - mkTyConApp tycon (map (substTyVar subst) univ_tvs) + case mb_insttys of + Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs) + Just insttys -> mkTyConApp ftycon insttys -- data instance + where + ftycon = case tyConFamily_maybe tycon of + Just ftycon -> ftycon + Nothing -> panic err + err = "dataConUserType: type patterns without family tycon" where subst = mkTopTvSubst eq_spec diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a385e8b..6af89b7 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -47,7 +47,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, - newTyConInstRhs, mkTopTvSubst, substTyVar ) + newTyConInstRhs, mkTopTvSubst, substTyVar, substTy ) import TcGadt ( gadtRefine, refineType, emptyRefinement ) import HsBinds ( ExprCoFn(..), isIdCoercion ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred ) @@ -61,8 +61,8 @@ import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Literal ( nullAddrLit, mkStringLit ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, - tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon, - newTyConCo ) + tyConStupidTheta, isProductTyCon, isDataTyCon, + isRecursiveTyCon, tyConFamily_maybe, newTyConCo ) import Class ( Class, classTyCon, classSelIds ) import Var ( Id, TyVar, Var, setIdType ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) @@ -70,12 +70,13 @@ import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..)) import OccName ( mkOccNameFS, varName ) import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars, +import DataCon ( DataCon, DataConIds(..), dataConTyCon, + dataConUnivTyVars, dataConInstTys, dataConFieldLabels, dataConRepArity, dataConResTys, dataConRepArgTys, dataConRepType, dataConFullSig, dataConStrictMarks, dataConExStricts, splitProductType, isVanillaDataCon, dataConFieldType, - deepSplitProductType + deepSplitProductType, ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, @@ -92,6 +93,7 @@ import NewDemand ( mkStrictSig, DmdResult(..), import DmdAnal ( dmdAnalTopRhs ) import CoreSyn import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) +import Maybe ( fromJust ) import Maybes import PrelNames import Util ( dropList, isSingleton ) @@ -196,13 +198,22 @@ mkDataConIds wrap_name wkr_name data_con | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper || not (null eq_spec) + || isInst = DCIds (Just alg_wrap_id) wrk_id | otherwise -- Algebraic, no wrapper = DCIds Nothing wrk_id where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con - tycon = dataConTyCon data_con + (univ_tvs, ex_tvs, eq_spec, + theta, orig_arg_tys) = dataConFullSig data_con + tycon = dataConTyCon data_con + (isInst, instTys, familyTyCon) = + case dataConInstTys data_con of + Nothing -> (False, [] , familyTyCon) + Just instTys -> (True , instTys, familyTyCon) + where + familyTyCon = fromJust $ tyConFamily_maybe tycon + -- this is defined whenever `isInst' ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args @@ -212,7 +223,10 @@ mkDataConIds wrap_name wkr_name data_con subst = mkTopTvSubst eq_spec dict_tys = mkPredTys theta result_ty_args = map (substTyVar subst) univ_tvs - result_ty = mkTyConApp tycon result_ty_args + familyArgs = map (substTy subst) instTys + result_ty = if isInst + then mkTyConApp familyTyCon familyArgs -- instance con + else mkTyConApp tycon result_ty_args -- ordinary con wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ mkFunTys orig_arg_tys $ result_ty -- NB: watch out here if you allow user-written equality @@ -256,7 +270,7 @@ mkDataConIds wrap_name wkr_name data_con -- RetCPR is only true for products that are real data types; -- that is, not unboxed tuples or [non-recursive] newtypes - ----------- Wrappers for newtypes -------------- + ----------- Workers for newtypes -------------- nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9ae85a2..ac28ddb 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -903,7 +903,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) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -912,7 +912,7 @@ 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 put_ bh aq @@ -944,7 +944,8 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7) + a8 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) 3 -> do aq <- get bh ar <- get bh @@ -1005,7 +1006,7 @@ instance Binary IfaceConDecls where return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1015,6 +1016,7 @@ instance Binary IfaceConDecl where put_ bh a7 put_ bh a8 put_ bh a9 + put_ bh a10 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh @@ -1024,7 +1026,8 @@ instance Binary IfaceConDecl where a7 <- get bh a8 <- get bh a9 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + a10 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index bf71ca8..05f5f4b 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -23,15 +23,16 @@ import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet ) import TysWiredIn ( unitTy ) import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) -import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc ) +import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, + mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, mkNewTyCoOcc, mkLocalOcc ) 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(..), - SynTyConRhs(..), newTyConRhs ) + SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, splitTyConApp_maybe, splitAppTy_maybe, @@ -67,11 +68,23 @@ buildAlgTyCon :: Name -> [TyVar] -> RecFlag -> Bool -- True <=> want generics functions -> Bool -- True <=> was declared in GADT syntax + -> Maybe TyCon -- Just family <=> instance of `family' -> TcRnIf m n TyCon buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn - = do { let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta - rhs fields is_rec want_generics gadt_syn + mb_family + = do { -- In case of a type instance, we need to invent a new name for the + -- instance type, as `tc_name' is the family name. + ; uniq <- newUnique + ; (final_name, parent) <- + case mb_family of + Nothing -> return (tc_name, NoParentTyCon) + Just family -> + do { final_name <- newImplicitBinder tc_name (mkLocalOcc uniq) + ; return (final_name, FamilyTyCon family) + } + ; let { tycon = mkAlgTyCon final_name kind tvs stupid_theta rhs + fields parent is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; fields = mkTyConSelIds tycon rhs } @@ -177,13 +190,14 @@ buildDataCon :: Name -> Bool -> ThetaType -- Does not include the "stupid theta" -- or the GADT equalities -> [Type] -> TyCon + -> Maybe [Type] -- Just ts <=> type pats of inst type -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) buildDataCon src_name declared_infix arg_stricts field_lbls - univ_tvs ex_tvs eq_spec ctxt arg_tys tycon + univ_tvs ex_tvs eq_spec ctxt arg_tys tycon mb_typats = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source @@ -195,7 +209,8 @@ buildDataCon src_name declared_infix arg_stricts field_lbls data_con = mkDataCon src_name declared_infix arg_stricts field_lbls univ_tvs ex_tvs eq_spec ctxt - arg_tys tycon stupid_ctxt dc_ids + arg_tys tycon mb_typats + stupid_ctxt dc_ids dc_ids = mkDataConIds wrap_name work_name data_con ; returnM data_con } @@ -271,7 +286,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec tvs [{- no existentials -}] [{- No equalities -}] [{-No context-}] dict_component_tys - rec_tycon + rec_tycon Nothing ; rhs <- case dict_component_tys of [rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 07f4a18..02fa5b5 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -70,16 +70,23 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifName :: OccName, -- Type constructor + | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? - ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax - ifGeneric :: Bool -- True <=> generic converter functions available - } -- We need this for imported data decls, since the - -- imported modules may have been compiled with - -- different flags to the current compilation unit + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifGeneric :: Bool, -- True <=> generic converter + -- functions available + -- We need this for imported + -- data decls, since the + -- imported modules may have + -- been compiled with + -- different flags to the + -- current compilation unit + ifFamily :: Maybe IfaceTyCon-- Just fam <=> instance of fam + } | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables @@ -130,8 +137,10 @@ data IfaceConDecl ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types - + ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + ifConInstTys :: Maybe [IfaceType] } -- instance types + data IfaceInst = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance @@ -249,9 +258,10 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec}) + ifRec = isrec, ifFamily = mbFamily}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls]) + 4 (vcat [pprRec isrec, pprGen gen, pprFamily mbFamily, + pp_condecls tycon condecls]) where pp_nd = case condecls of IfAbstractTyCon -> ptext SLIT("data") @@ -272,6 +282,9 @@ pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec pprGen True = ptext SLIT("Generics: yes") pprGen False = ptext SLIT("Generics: no") +pprFamily Nothing = ptext SLIT("DataFamily: none") +pprFamily (Just fam) = ptext SLIT("DataFamily:") <+> ppr fam + instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty @@ -529,6 +542,7 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) ifRec d1 == ifRec d2 && ifGadtSyntax d1 == ifGadtSyntax d2 && ifGeneric d1 == ifGeneric d2) &&& + ifFamily d1 `eqIfTc_mb` ifFamily d2 &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& eq_hsCD env (ifCons d1) (ifCons d2) @@ -536,6 +550,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- The type variables of the data type do not scope -- over the constructors (any more), but they do scope -- over the stupid context in the IfaceConDecls + where + Nothing `eqIfTc_mb` Nothing = Equal + (Just fam1) `eqIfTc_mb` (Just fam2) = fam1 `eqIfTc` fam2 + _ `eqIfTc_mb` _ = NotEqual eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d4548db..4cb2b53 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -190,10 +190,12 @@ import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) + tyConArity, tyConTyVars, algTyConRhs, tyConExtName, + tyConFamily_maybe ) import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec, - dataConTheta, dataConOrigArgTys ) + dataConTyCon, dataConIsInfix, dataConUnivTyVars, + dataConExTyVars, dataConEqSpec, dataConTheta, + dataConOrigArgTys, dataConInstTys ) import Type ( TyThing(..), splitForAllTys, funResultTy ) import TcType ( deNoteType ) import TysPrim ( alphaTyVars ) @@ -1033,7 +1035,8 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon } + ifGeneric = tyConHasGenerics tycon, + ifFamily = fmap (toIfaceTyCon ext) $ tyConFamily_maybe tycon } | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, @@ -1047,7 +1050,8 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = IfAbstractTyCon, ifGadtSyntax = False, ifGeneric = False, - ifRec = NonRecursive} + ifRec = NonRecursive, + ifFamily = Nothing } | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where @@ -1075,9 +1079,13 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), - ifConStricts = dataConStrictMarks data_con } + ifConArgTys = map (toIfaceType ext) + (dataConOrigArgTys data_con), + ifConFields = map getOccName + (dataConFieldLabels data_con), + ifConStricts = dataConStrictMarks data_con, + ifConInstTys = fmap (map (toIfaceType ext)) + (dataConInstTys data_con) } to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 08dfe8c..388d040 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -30,7 +30,8 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, ubxTupleKindTyCon, mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName, SynTyConRhs(..) ) +import TyCon ( TyCon, tyConName, SynTyConRhs(..), + AlgTyConParent(..) ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), @@ -68,6 +69,7 @@ import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, equalLength, splitAtList ) import DynFlags ( DynFlag(..), isOneShot ) +import Monad ( liftM ) \end{code} This module takes @@ -358,15 +360,22 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifGeneric = want_generic }) + ifGeneric = want_generic, + ifFamily = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; family <- case mb_family of + Nothing -> return Nothing + Just fam -> + do { famTyCon <- tcIfaceTyCon fam + ; return $ Just famTyCon + } ; buildAlgTyCon tc_name tyvars stupid_theta - cons is_rec want_generic gadt_syn + cons is_rec want_generic gadt_syn family }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) @@ -428,7 +437,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, ifConArgTys = args, ifConFields = field_lbls, - ifConStricts = stricts}) + ifConStricts = stricts, ifConInstTys = mb_insttys }) = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ @@ -447,12 +456,17 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- the component types unless they are really needed ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) ; lbl_names <- mappM lookupIfaceTop field_lbls + ; mb_insttys' <- case mb_insttys of + Nothing -> return Nothing + Just insttys -> liftM Just $ + mappM tcIfaceType insttys ; buildDataCon name is_infix {- Not infix -} stricts lbl_names univ_tyvars ex_tyvars eq_spec theta arg_tys tycon + mb_insttys' } mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index e713eb7..db80d3c 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -67,7 +67,8 @@ import OccName ( mkOccNameFS, tcName, dataName, mkTupleOcc, import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, - mkTupleTyCon, mkAlgTyCon, tyConName ) + mkTupleTyCon, mkAlgTyCon, tyConName, + AlgTyConParent(NoParentTyCon) ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) @@ -204,6 +205,7 @@ pcTyCon is_enum is_rec name tyvars cons [] -- No stupid theta (DataTyCon cons is_enum) [] -- No record selectors + NoParentTyCon is_rec True -- All the wired-in tycons have generics False -- Not in GADT syntax @@ -230,6 +232,7 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon [] -- No equality spec [] -- No theta arg_tys tycon + Nothing -- not a data instance [] -- No stupid theta (mkDataConIds bogus_wrap_name wrk_name data_con) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 6a43e23..30a47f7 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -630,7 +630,8 @@ tcDataKindSig :: Maybe Kind -> TcM [TyVar] -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T :: * -> * -> * where ... -- This function makes up suitable (kinded) type variables for --- the argument kinds, and checks that the result kind is indeed * +-- the argument kinds, and checks that the result kind is indeed *. +-- We use it also to make up argument type variables for for data instances. tcDataKindSig Nothing = return [] tcDataKindSig (Just kind) = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 1aa126f..2a51661 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -22,13 +22,13 @@ import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, import InstEnv ( mkLocalInstance, instanceDFunId ) import TcDeriv ( tcDeriving ) import TcEnv ( InstInfo(..), InstBindings(..), - newDFunName, tcExtendIdEnv + newDFunName, tcExtendIdEnv, tcExtendGlobalEnv ) import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifySuperClasses ) import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, - splitFunTys ) + splitFunTys, TyThing ) import Coercion ( mkSymCoercion ) import TyCon ( TyCon, newTyConCo, tyConTyVars ) import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys ) @@ -44,6 +44,7 @@ import ListSetOps ( minusList ) import Outputable import Bag import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) ) +import HscTypes ( implicitTyThings ) import FastString \end{code} @@ -146,24 +147,35 @@ tcInstDecls1 tycl_decls inst_decls -- (1) Do the ordinary instance declarations and instances of -- indexed types ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls } - ; local_inst_infos <- mappM tcLocalInstDecl1 inst_decls - ; idxty_inst_infos <- mappM tcIdxTyInstDecl idxty_decls - - ; let { local_inst_info = concat local_inst_infos ++ - catMaybes idxty_inst_infos - ; clas_decls = filter (isClassDecl.unLoc) tycl_decls } - - -- (2) Instances from generic class declarations + ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls + ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls + + ; let { (local_infos, + local_tycons) = unzip local_info_tycons + ; (idxty_infos, + idxty_tycons) = unzip idxty_info_tycons + ; local_idxty_info = concat local_infos ++ catMaybes idxty_infos + ; local_idxty_tycon = concat local_tycons ++ + catMaybes idxty_tycons + ; clas_decls = filter (isClassDecl.unLoc) tycl_decls + ; implicit_things = concatMap implicitTyThings local_idxty_tycon + } + + -- (2) Add the tycons of associated types and their implicit + -- tythings to the global environment + ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do { + + -- (3) Instances from generic class declarations ; generic_inst_info <- getGenericInstances clas_decls -- Next, construct the instance environment so far, consisting -- of -- a) local instance decls -- b) generic instances - ; addInsts local_inst_info $ do { + ; addInsts local_idxty_info $ do { ; addInsts generic_inst_info $ do { - -- (3) Compute instances from "deriving" clauses; + -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls @@ -171,9 +183,9 @@ tcInstDecls1 tycl_decls inst_decls ; gbl_env <- getGblEnv ; returnM (gbl_env, - generic_inst_info ++ deriv_inst_info ++ local_inst_info, + generic_inst_info ++ deriv_inst_info ++ local_idxty_info, deriv_binds) - }}}} + }}}}} addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside @@ -182,14 +194,14 @@ addInsts infos thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM [InstInfo] -- [] if there was an error + -> TcM ([InstInfo], [TyThing]) -- [] if there was an error -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) = -- Prime error recovery, set source location - recoverM (returnM []) $ + recoverM (returnM ([], [])) $ setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -208,18 +220,22 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; checkValidInstance tyvars theta clas inst_tys -- Next, process any associated types. - ; idxty_inst_info <- mappM tcIdxTyInstDecl ats + ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc) ; overlap_flag <- getOverlapFlag - ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys - ispec = mkLocalInstance dfun overlap_flag - - ; return $ [InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }] ++ - catMaybes idxty_inst_info } + ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + (idxty_infos, + idxty_tycons) = unzip idxty_info_tycons + + ; return ([InstInfo { iSpec = ispec, + iBinds = VanillaInst binds uprags }] ++ + catMaybes idxty_infos, + catMaybes idxty_tycons) + } \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ccefb00..c2054e3 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -14,7 +14,8 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), NewOrData(..), ResType(..), tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType + hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), + mkHsAppTy ) import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) @@ -247,12 +248,13 @@ they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl :: LTyClDecl Name + -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ + recoverM (returnM (Nothing, Nothing)) $ + setSrcSpan loc $ + tcAddDeclCtxt decl $ do { -- indexed data types require -fglasgow-exts and can't be in an -- hs-boot file ; gla_exts <- doptM Opt_GlasgowExts @@ -264,10 +266,11 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name + -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> + = kcIdxTyPats decl $ \k_tvs k_typats resKind _ -> do { -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind @@ -278,16 +281,16 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) -- construct type rewrite rule -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need InstInfo for indexed types + ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms }} -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, +tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; let k_ctxt = tcdCtxt decl - k_cons = tcdCons decl + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_decl -- result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name @@ -300,14 +303,16 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) $ - newtypeConError tc_name (length cons) + ; checkTc (new_or_data == DataType || isSingleton k_cons) $ + newtypeConError tc_name (length k_cons) + ; final_tvs <- tcDataKindSig (Just $ tyConKind family) ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt + ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + tycon final_tvs (Just t_typats))) k_cons ; tc_rhs <- case new_or_data of @@ -315,9 +320,8 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tc_name tycon (head data_cons) - --vvvvvvv !!! need a new derived tc_name here ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax + False h98_syntax (Just family) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -326,8 +330,8 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, }) -- construct result - -- !!!twofold: (1) (ATyCon tycon) and (2) an equality axiom - ; return Nothing -- !!!TODO: need InstInfo for indexed types + -- !!!TODO: missing eq axiom + ; return (Nothing, Just (ATyCon tycon)) }} where h98_syntax = case cons of -- All constructors have same shape @@ -344,15 +348,15 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, -- check is only required for type functions. -- kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a) + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let { tc_kind = case tc_ty_thing of - AGlobal (ATyCon tycon) -> tyConKind tycon - ; (kinds, resKind) = splitKindFunTys tc_kind + ; let { family = case tc_ty_thing of + AGlobal (ATyCon family) -> family + ; (kinds, resKind) = splitKindFunTys (tyConKind family) ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates @@ -362,7 +366,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind ; typats <- zipWithM kcCheckHsType hs_typats kinds - ; thing_inside tvs typats resultKind + ; thing_inside tvs typats resultKind family } where \end{code} @@ -638,7 +642,7 @@ tcTyClDecl1 _calc_isrec (case new_or_data of DataType -> OpenDataTyCon NewType -> OpenNewTyCon) - Recursive False True + Recursive False True Nothing ; return [ATyCon tycon] } @@ -674,7 +678,7 @@ tcTyClDecl1 calc_isrec ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + tycon final_tvs Nothing)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -685,7 +689,7 @@ tcTyClDecl1 calc_isrec ASSERT( isSingleton data_cons ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) h98_syntax + (want_generic && canDoGenerics data_cons) h98_syntax Nothing }) ; return [ATyCon tycon] } @@ -730,10 +734,13 @@ tcTyClDecl1 calc_isrec ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] - -> ConDecl Name -> TcM DataCon + -> NewOrData + -> TyCon -> [TyVar] + -> Maybe [Type] -- Just ts <=> type patterns of instance type + -> ConDecl Name + -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes +tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype @@ -743,19 +750,21 @@ tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes tc_tvs [] -- No existentials [] [] -- No equalities, predicates [arg_ty'] - tycon } + tycon + mb_typats} -- Check that a newtype has no existential stuff ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) ; case details of - PrefixCon [arg_ty] -> tc_datacon [] arg_ty + PrefixCon [arg_ty] -> tc_datacon [] arg_ty RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty - other -> failWithTc (newtypeFieldErr name (length (hsConArgs details))) + other -> + failWithTc (newtypeFieldErr name (length (hsConArgs details))) -- Check that the constructor has exactly one field } -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types +tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types (ConDecl name _ tvs ctxt details res_ty) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -768,10 +777,11 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types (argStrictness unbox_strict tycon bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys - data_tc } - -- NB: we put data_tc, the type constructor gotten from the constructor - -- type signature into the data constructor; that way - -- checkValidDataCon can complain if it's wrong. + data_tc + mb_typats} + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. ; case details of PrefixCon btys -> tc_datacon False [] btys diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 5ab8458..7fcc52b 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -10,7 +10,7 @@ module TyCon( PrimRep(..), tyConPrimRep, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..), SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, @@ -47,6 +47,7 @@ module TyCon( tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, + isFamInstTyCon, tyConFamily_maybe, synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types @@ -115,8 +116,9 @@ data TyCon hasGenerics :: Bool, -- True <=> generic to/from functions are available -- (in the exports of the data type's source module) - algTcClass :: Maybe Class - -- Just cl if this tycon came from a class declaration + algTcParent :: AlgTyConParent -- Gives the class or family tycon for + -- derived tycons representing classes + -- or family instances, respectively. } | TupleTyCon { @@ -235,6 +237,10 @@ visibleDataCons OpenNewTyCon = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] +data AlgTyConParent = NoParentTyCon -- ordinary data type + | ClassTyCon Class -- class dictionary + | FamilyTyCon TyCon -- instance of type family + data SynTyConRhs = OpenSynTyCon Kind -- Type family: *result* kind given | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for @@ -371,7 +377,7 @@ mkFunTyCon name kind -- 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 stupid rhs sel_ids is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -381,28 +387,14 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids is_rec gen_info gadt_syn algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, - algTcClass = Nothing, + algTcParent = parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn, hasGenerics = gen_info } -mkClassTyCon name kind tyvars rhs clas is_rec - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - algTcStupidTheta = [], - algTcRhs = rhs, - algTcSelIds = [], - algTcClass = Just clas, - algTcRec = is_rec, - algTcGadtSyntax = False, -- Doesn't really matter - hasGenerics = False - } - +mkClassTyCon name kind tyvars rhs clas is_rec = + mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { @@ -677,9 +669,11 @@ tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = length cons -tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = + length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = OpenDataTyCon}) = 0 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -752,12 +746,20 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr \begin{code} isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcClass = Just _}) = True -isClassTyCon other_tycon = False +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True +isClassTyCon other_tycon = False tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas -tyConClass_maybe ther_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas +tyConClass_maybe ther_tycon = Nothing + +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _}) = True +isFamInstTyCon other_tycon = False + +tyConFamily_maybe :: TyCon -> Maybe TyCon +tyConFamily_maybe (AlgTyCon {algTcParent = FamilyTyCon fam}) = Just fam +tyConFamily_maybe ther_tycon = Nothing \end{code}