From: Manuel M T Chakravarty Date: Wed, 25 Apr 2007 09:16:46 +0000 (+0000) Subject: Generating synonym instance representation tycons X-Git-Tag: 2007-05-06~120 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=13cd965d80be5c25dc54534a833df39ab7aa7a12 Generating synonym instance representation tycons - Type synonym instances are turned into representation synonym tycons - They are entered into the pool of family instances (FamInst environments) in the same way as data/newtype instances - Still missing is writing the parent tycon information into ifaces and various well-formedness checks. --- diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index aa01e70..8689306 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -36,16 +36,29 @@ import Data.List \begin{code} ------------------------------------------------------ -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) +buildSynTyCon :: Name -> [TyVar] + -> SynTyConRhs + -> Maybe (TyCon, [Type]) -- family instance if applicable + -> TcRnIf m n TyCon +buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _ + = let + kind = mkArrowKinds (map tyVarKind tvs) rhs_ki + in + return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon + +buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family + = do { -- We need to tie a knot as the coercion of a data instance depends + -- on the instance representation tycon and vice versa. + ; tycon <- fixM (\ tycon_rec -> do + { parent <- mkParentInfo mb_family tc_name tvs tycon_rec + ; let { tycon = mkSynTyCon tc_name kind tvs rhs parent + ; kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) + } + ; return tycon + }) + ; return tycon + } ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] @@ -62,7 +75,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn = do { -- We need to tie a knot as the coercion of a data instance depends -- on the instance representation tycon and vice versa. ; tycon <- fixM (\ tycon_rec -> do - { parent <- parentInfo mb_family tycon_rec + { parent <- mkParentInfo mb_family tc_name tvs tycon_rec ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs fields parent is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind @@ -72,29 +85,32 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn }) ; return tycon } - where - -- If a family tycon with instance types is given, the current tycon is an - -- instance of that family and we need to - -- - -- (1) create a coercion that identifies the family instance type and the - -- representation type from Step (1); ie, it is of the form - -- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion, - -- `F' the family tycon and `R' the (derived) representation tycon, - -- and - -- (2) produce a `AlgTyConParent' value containing the parent and coercion - -- information. - -- - parentInfo Nothing rep_tycon = - return NoParentTyCon - parentInfo (Just (family, instTys)) rep_tycon = - do { -- Create the coercion - ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkDataInstCoercion co_tycon_name tvs - family instTys rep_tycon - ; return $ FamilyTyCon family instTys co_tycon - } - +-- If a family tycon with instance types is given, the current tycon is an +-- instance of that family and we need to +-- +-- (1) create a coercion that identifies the family instance type and the +-- representation type from Step (1); ie, it is of the form +-- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion, +-- `F' the family tycon and `R' the (derived) representation tycon, +-- and +-- (2) produce a `TyConParent' value containing the parent and coercion +-- information. +-- +mkParentInfo :: Maybe (TyCon, [Type]) + -> Name -> [TyVar] + -> TyCon + -> TcRnIf m n TyConParent +mkParentInfo Nothing _ _ _ = + return NoParentTyCon +mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon = + do { -- Create the coercion + ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc + ; let co_tycon = mkFamInstCoercion co_tycon_name tvs + family instTys rep_tycon + ; return $ FamilyTyCon family instTys co_tycon + } + ------------------------------------------------------ mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8bbb79a..2e3c8ed 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -383,7 +383,9 @@ tcIfaceDecl ignore_prags ; rhs_tyki <- tcIfaceType rdr_rhs_ty ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) + -- !!!TODO: read mb_family info from iface and pass as last argument + ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing + ; return $ ATyCon tycon } tcIfaceDecl ignore_prags diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 2a819f0..278e333 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -69,7 +69,7 @@ import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName, - AlgTyConParent(NoParentTyCon) ) + TyConParent(NoParentTyCon) ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index ff49db6..8f4fbc9 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -650,7 +650,7 @@ newDFunName clas (ty:_) loc newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} -Make a name for the representation tycon of a data/newtype instance. It's an +Make a name for the representation tycon of a family instance. It's an *external* name, like otber top-level names, and hence must be made with newGlobalBinder. diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a1ca8ca..dbf83fb 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl) tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcFamInstDecl1 (decl@TySynonym {}) + -- "type instance" +tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for a synonym unless (isSynTyCon family) $ @@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {}) ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need TyThing for indexed synonym + -- (3) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) + ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (Just (family, t_typats)) + + ; return $ Just (ATyCon tycon) }} - + + -- "newtype instance" and "data instance" tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> @@ -300,6 +306,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt + -- (3) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) @@ -587,12 +594,15 @@ tcSynDecls (decl : decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } + -- "type" tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; return (ATyCon tycon) + } -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -614,7 +624,8 @@ tcTyClDecl1 _calc_isrec -- Check that we don't use families without -findexed-types ; checkTc idx_tys $ badFamInstDecl tc_name - ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)] + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; return [ATyCon tycon] } -- "newtype family" or "data family" declaration @@ -639,7 +650,7 @@ tcTyClDecl1 _calc_isrec ; return [ATyCon tycon] } - -- "newtype", "data", "newtype instance", "data instance" + -- "newtype" and "data" tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index b9c6ea7..49ae740 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -25,7 +25,7 @@ module Coercion ( mkSymCoercion, mkTransCoercion, mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion, mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion, - mkNewTypeCoercion, mkDataInstCoercion, mkAppsCoercion, + mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion, splitNewTypeRepCo_maybe, decomposeCo, @@ -294,18 +294,18 @@ mkNewTypeCoercion name tycon tvs rhs_ty rule args = ASSERT( co_con_arity == length args ) (TyConApp tycon args, substTyWith tvs args rhs_ty) --- Coercion identifying a data/newtype representation type and its family --- instance. It has the form `Co tvs :: F ts :=: R tvs', where `Co' is the --- coercion tycon built here, `F' the family tycon and `R' the (derived) +-- Coercion identifying a data/newtype/synonym representation type and its +-- family instance. It has the form `Co tvs :: F ts :=: R tvs', where `Co' is +-- the coercion tycon built here, `F' the family tycon and `R' the (derived) -- representation tycon. -- -mkDataInstCoercion :: Name -- unique name for the coercion tycon - -> [TyVar] -- type parameters of the coercion (`tvs') - -> TyCon -- family tycon (`F') - -> [Type] -- type instance (`ts') - -> TyCon -- representation tycon (`R') - -> TyCon -- => coercion tycon (`Co') -mkDataInstCoercion name tvs family instTys rep_tycon +mkFamInstCoercion :: Name -- unique name for the coercion tycon + -> [TyVar] -- type parameters of the coercion (`tvs') + -> TyCon -- family tycon (`F') + -> [Type] -- type instance (`ts') + -> TyCon -- representation tycon (`R') + -> TyCon -- => coercion tycon (`Co') +mkFamInstCoercion name tvs family instTys rep_tycon = mkCoercionTyCon name coArity rule where coArity = length tvs diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 60b55d1..c8a509f 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -51,7 +51,7 @@ data FamInst -- Used for "rough matching"; same idea as for class instances , fi_tcs :: [Maybe Name] -- Top of type args - -- INVARIANT: fi_tcs = roughMatchTcs is_tys + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys -- Used for "proper matching"; ditto , fi_tvs :: TyVarSet -- Template tyvars for full match diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index dfbf02c..cf2de89 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -13,7 +13,7 @@ module TyCon( tyConPrimRep, AlgTyConRhs(..), visibleDataCons, - AlgTyConParent(..), + TyConParent(..), SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, @@ -125,7 +125,7 @@ data TyCon hasGenerics :: Bool, -- True <=> generic to/from functions are available -- (in the exports of the data type's source module) - algTcParent :: AlgTyConParent -- Gives the class or family tycon for + algTcParent :: TyConParent -- Gives the class or family tycon for -- derived tycons representing classes -- or family instances, respectively. } @@ -149,7 +149,12 @@ data TyCon tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs -- Expanded type in here + synTcRhs :: SynTyConRhs, -- Expanded type in here + + synTcParent :: TyConParent -- Gives the family tycon of + -- representation tycons of family + -- instances + } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -262,12 +267,13 @@ visibleDataCons OpenTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] --- Both type classes as well as data/newtype family instances imply implicit --- type constructors. These implicit type constructors refer to their parent +-- Both type classes as well as family instances imply implicit type +-- constructors. These implicit type constructors refer to their parent -- structure (ie, the class or family from which they derive) using a type of --- the following form. +-- the following form. We use `TyConParent' for both algebraic and synonym +-- types, but the variant `ClassTyCon' will only be used by algebraic tycons. -- -data AlgTyConParent +data TyConParent = NoParentTyCon -- An ordinary type constructor has no parent. | ClassTyCon -- Type constructors representing a class dictionary. @@ -297,7 +303,7 @@ data SynTyConRhs | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for -- the expansion when the tycon is applied to some - -- types. + -- types. \end{code} Note [Newtype coercions] @@ -498,14 +504,15 @@ mkPrimTyCon' name kind arity rep is_unlifted tyConExtName = Nothing } -mkSynTyCon name kind tyvars rhs +mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - synTcRhs = rhs + synTcRhs = rhs, + synTcParent = parent } mkCoercionTyCon name arity kindRule @@ -860,17 +867,22 @@ tyConClass_maybe other_tycon = Nothing isFamInstTyCon :: TyCon -> Bool isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True +isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True isFamInstTyCon other_tycon = False tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = Just (fam, instTys) +tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) = + Just (fam, instTys) tyConFamInst_maybe other_tycon = Nothing tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = Just coe +tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) = + Just coe tyConFamilyCoercion_maybe other_tycon = Nothing \end{code}