diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-09-17 11:54:20 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-09-18 17:30:15 +0100 |
commit | 58470fb7b4a25c49b567e08740dc8df01a6c3710 (patch) | |
tree | 727201b8e30dd42cbb53d15e03571c3bcbb43b79 | |
parent | af7cc9953217d74e88d4d21512e957edd8e97ec9 (diff) | |
download | haskell-58470fb7b4a25c49b567e08740dc8df01a6c3710.tar.gz |
Make a start towards eta-rules and injective families
* Make Any into a type family (which it should always have been)
This is to support the future introduction of eta rules for
product types (see email on ghc-users title "PolyKind issue"
early Sept 2012)
* Add the *internal* data type support for
(a) closed type families [so that you can't give
type instance for 'Any']
(b) injective type families [because Any is really
injective]
This amounts to two boolean flags on the SynFamilyTyCon
constructor of TyCon.SynTyConRhs.
There is some knock-on effect, but all of a routine nature.
It remains to offer source syntax for either closed or
injective families.
-rw-r--r-- | compiler/iface/BinIface.hs | 12 | ||||
-rw-r--r-- | compiler/iface/BuildTyCl.lhs | 2 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.lhs | 15 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 18 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 6 | ||||
-rw-r--r-- | compiler/main/GHC.hs | 2 | ||||
-rw-r--r-- | compiler/main/PprTyThing.hs | 14 | ||||
-rw-r--r-- | compiler/prelude/TysPrim.lhs | 17 | ||||
-rw-r--r-- | compiler/stgSyn/CoreToStg.lhs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 11 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.lhs | 5 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 7 | ||||
-rw-r--r-- | compiler/typecheck/TcTyDecls.lhs | 5 | ||||
-rw-r--r-- | compiler/typecheck/TcType.lhs | 5 | ||||
-rw-r--r-- | compiler/types/TyCon.lhs | 68 |
16 files changed, 112 insertions, 87 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 362df3fc35..616bc0acf4 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1404,6 +1404,18 @@ instance Binary IfaceDecl where occ <- return $! mkOccNameFS tcName a1 return (IfaceAxiom occ a2 a3 a4) +instance Binary ty => Binary (SynTyConRhs ty) where + put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh + ; b <- get bh + ; return (SynFamilyTyCon a b) } + _ -> do { ty <- get bh + ; return (SynonymTyCon ty) } } + instance Binary IfaceClsInst where put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 9456bdaf34..5f5e8a1896 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -46,7 +46,7 @@ import Outputable \begin{code} ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] - -> SynTyConRhs + -> SynTyConRhs Type -> Kind -- ^ Kind of the RHS -> TyConParent -> TcRnIf m n TyCon diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index a41a9dac47..06c7b67ba6 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -35,6 +35,7 @@ module IfaceSyn ( #include "HsVersions.h" +import TyCon( SynTyConRhs(..) ) import IfaceType import CoreSyn( DFunArg, dfunArgExprs ) import PprCore() -- Printing DFunArgs @@ -89,9 +90,7 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn - -- Nothing for an type family declaration - } + ifSynRhs :: SynTyConRhs IfaceType } | IfaceClass { ifCtxt :: IfaceContext, -- Context... ifName :: OccName, -- Name of the class TyCon @@ -487,12 +486,12 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty}) + ifSynRhs = SynonymTyCon mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) + ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) @@ -797,9 +796,9 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon -freeNamesIfSynRhs :: Maybe IfaceType -> NameSet -freeNamesIfSynRhs (Just ty) = freeNamesIfType ty -freeNamesIfSynRhs Nothing = emptyNameSet +freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet +freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty +freeNamesIfSynRhs _ = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d92cb4a185..a4a9dfc5f6 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1459,11 +1459,11 @@ tyConToIfaceDecl env tycon | Just clas <- tyConClass_maybe tycon = classToIfaceDecl env clas - | isSynTyCon tycon + | Just syn_rhs <- synTyConRhs_maybe tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifSynRhs = syn_rhs, - ifSynKind = syn_ki } + ifSynRhs = to_ifsyn_rhs syn_rhs, + ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1483,18 +1483,12 @@ tyConToIfaceDecl env tycon where (env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon) - (syn_rhs, syn_ki) - = case synTyConRhs tycon of - SynFamilyTyCon -> - ( Nothing - , tidyToIfaceType env1 (synTyConResKind tycon) ) - SynonymTyCon ty -> - ( Just (tidyToIfaceType env1 ty) - , tidyToIfaceType env1 (typeKind ty) ) + to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b + to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon + ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index eb9e5ddb80..b9783a8d4f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -474,9 +474,9 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n - tc_syn_rhs Nothing = return SynFamilyTyCon - tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty - ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b) + tc_syn_rhs (SynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index b1cc786840..06b3ecaf23 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -159,7 +159,7 @@ module GHC ( tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, isFamilyTyCon, tyConClass_maybe, - synTyConDefn, synTyConType, synTyConResKind, + synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, -- ** Type variables TyVar, diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1ee18f84e3..0fa7bdff52 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -165,13 +165,13 @@ pprTypeForUser print_foralls ty pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon - | GHC.isSynTyCon tyCon - = if GHC.isFamilyTyCon tyCon - then pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) - else - let rhs_type = GHC.synTyConType tyCon - in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) + | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon + = case syn_rhs of + SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) + SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) + 2 (pprTypeForUser pefas rhs_ty) + | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls | otherwise diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 1b8d96df35..792c174196 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -654,7 +654,13 @@ The type constructor Any of kind forall k. k -> k has these properties: primitive type: - has a fixed unique, anyTyConKey, - lives in the global name cache - - built with TyCon.PrimTyCon + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency becuase 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other * It is lifted, and hence represented by a pointer @@ -711,8 +717,13 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep - where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) +anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] + syn_rhs + NoParentTyCon + where + kind = ForAllTy kKiVar (mkTyVarTy kKiVar) + syn_rhs = SynFamilyTyCon { synf_open = False, synf_injective = True } + -- NB Closed, injective anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index eed579eed7..6c315b36f0 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -476,8 +476,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of where _is_poly_alt_tycon tc = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. arising from strict + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 7a41869600..9d83aed709 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -560,7 +560,6 @@ tcFamInstDecl top_lvl decl -- Look up the family TyCon and check for validity including -- check that toplevel type instances are not for associated types. ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) (addErr $ assocInClassErr fam_tc_lname) @@ -573,7 +572,11 @@ tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst -- "type instance" tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name , fid_defn = TySynonym {} }) - = do { -- (1) do the work of verifying the synonym + = do { -- (0) Check it's an open type family + checkTc (isOpenSynFamilyTyCon fam_tc) + (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl -- (2) check the well-formedness of the instance @@ -1445,4 +1448,8 @@ badFamInstDecl tc_name = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b699d63e8a..d48be70038 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -771,19 +771,20 @@ checkBootTyCon tc1 tc2 eqListBy eqSig op_stuff1 op_stuff2 && eqListBy eqAT ats1 ats2) - | isSynTyCon tc1 && isSynTyCon tc2 + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 = ASSERT(tc1 == tc2) let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 env = rnBndrs2 env0 tvs1 tvs2 - eqSynRhs SynFamilyTyCon SynFamilyTyCon - = True + eqSynRhs (SynFamilyTyCon a1 b1) (SynFamilyTyCon a2 b2) + = a1 == a2 && b1 == b2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False in equalLength tvs1 tvs2 && - eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + eqSynRhs syn_rhs1 syn_rhs2 | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 18fa3cb548..49beb13fbb 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1227,9 +1227,8 @@ reifyTyCon tc (TH.FamilyD flavour (reifyName tc) tvs' kind') instances) } - | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs + | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs ; tvs' <- reifyTyVars tvs ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 40ed8983c1..22e17b75b7 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -533,7 +533,8 @@ tcTyClDecl1 parent _calc_isrec = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name - ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent + ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False } + ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent ; return [ATyCon tycon] } -- "data family" declaration @@ -1306,8 +1307,8 @@ checkValidTyCon tc | Just cl <- tyConClass_maybe tc = checkValidClass cl - | isSynTyCon tc - = case synTyConRhs tc of + | Just syn_rhs <- synTyConRhs_maybe tc + = case syn_rhs of SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 583eb56c89..3df8209eed 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -211,9 +211,8 @@ calcClassCycles cls -- For synonyms, try to expand them: some arguments might be -- phantoms, after all. We can expand with impunity because at -- this point the type synonym cycle check has already happened. - | isSynTyCon tc - , SynonymTyCon rhs <- synTyConRhs tc - , let (env, remainder) = papp (tyConTyVars tc) tys + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , let (env, remainder) = papp tvs tys rest_tys = either (const []) id remainder = expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index e129bac53c..b8594afcec 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -916,8 +916,8 @@ isTauTy _ = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype isTauTyCon tc - | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc)) - | otherwise = True + | Just (_, rhs) <- synTyConDefn_maybe tc = isTauTy rhs + | otherwise = True --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to @@ -1375,6 +1375,7 @@ orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNa orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty orphNamesOfCos :: [Coercion] -> NameSet diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 06fef36102..9a4a1c4dc8 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -12,7 +12,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), -- ** Coercion axiom constructors CoAxiom(..), @@ -38,7 +38,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, + isSynTyCon, isOpenSynFamilyTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, @@ -66,7 +66,7 @@ module TyCon( tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - synTyConDefn, synTyConRhs, synTyConType, + synTyConDefn_maybe, synTyConRhs_maybe, tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, @@ -359,8 +359,8 @@ data TyCon tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs, -- ^ Contains information about the - -- expansion of the synonym + synTcRhs :: SynTyConRhs Type, -- ^ Contains information about the + -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' -- of 'TyCon's representing family instances @@ -566,17 +566,28 @@ isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) -data SynTyConRhs +data SynTyConRhs ty = -- | An ordinary type synonyn. SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + ty -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. -- | A type synonym family e.g. @type family F x y :: * -> *@ - | SynFamilyTyCon + | SynFamilyTyCon { + synf_open :: Bool, -- See Note [Closed type families] + synf_injective :: Bool + } \end{code} +Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put instnaces where the family + is defined. GHC doesn't support syntax for this yet. + Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A data constructor can be promoted to become a type constructor, @@ -918,7 +929,7 @@ mkPrimTyCon' name kind arity rep is_unlifted } -- | Create a type synonym 'TyCon' -mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon +mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs Type -> TyConParent -> TyCon mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, @@ -1106,15 +1117,15 @@ isSynFamilyTyCon :: TyCon -> Bool isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True isSynFamilyTyCon _ = False +isOpenSynFamilyTyCon :: TyCon -> Bool +isOpenSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon { synf_open = is_open } }) = is_open +isOpenSynFamilyTyCon _ = False + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isDataFamilyTyCon _ = False --- | Is this a synonym 'TyCon' that can have no further instances appear? -isClosedSynTyCon :: TyCon -> Bool -isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) - -- | Injective 'TyCon's can be decomposed, so that -- T ty1 ~ T ty2 => ty1 ~ ty2 isInjectiveTyCon :: TyCon -> Bool @@ -1351,26 +1362,17 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} \begin{code} --- | Extract the 'TyVar's bound by a type synonym and the corresponding (unsubstituted) right hand side. --- If the given 'TyCon' is not a type synonym, panics -synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) - = (tyvars, ty) -synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) - --- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. Panics --- if the given 'TyCon' is not a type synonym -synTyConRhs :: TyCon -> SynTyConRhs -synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs -synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) - --- | Find the expansion of the type synonym represented by the given 'TyCon'. The free variables of this --- type will typically include those 'TyVar's bound by the 'TyCon'. Panics if the 'TyCon' is not that of --- a type synonym -synTyConType :: TyCon -> Type -synTyConType tc = case synTcRhs tc of - SynonymTyCon t -> t - _ -> pprPanic "synTyConType" (ppr tc) +-- | Extract the 'TyVar's bound by a vanilla type synonym (not familiy) +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe (SynTyConRhs Type) +synTyConRhs_maybe (SynTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing \end{code} \begin{code} |