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

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.
parent 0560e796
...@@ -36,16 +36,29 @@ import Data.List ...@@ -36,16 +36,29 @@ import Data.List
\begin{code} \begin{code}
------------------------------------------------------ ------------------------------------------------------
buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon buildSynTyCon :: Name -> [TyVar]
buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki _) -> SynTyConRhs
= mkSynTyCon name kind tvs rhs -> Maybe (TyCon, [Type]) -- family instance if applicable
where -> TcRnIf m n TyCon
buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
= let
kind = mkArrowKinds (map tyVarKind tvs) rhs_ki kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty) in
= mkSynTyCon name kind tvs rhs return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
where
kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
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] buildAlgTyCon :: Name -> [TyVar]
...@@ -62,7 +75,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn ...@@ -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 = do { -- We need to tie a knot as the coercion of a data instance depends
-- on the instance representation tycon and vice versa. -- on the instance representation tycon and vice versa.
; tycon <- fixM (\ tycon_rec -> do ; 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 ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
fields parent is_rec want_generics gadt_syn fields parent is_rec want_generics gadt_syn
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
...@@ -72,29 +85,32 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn ...@@ -72,29 +85,32 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
}) })
; return tycon ; return tycon
} }
where
-- If a family tycon with instance types is given, the current tycon is an -- If a family tycon with instance types is given, the current tycon is an
-- instance of that family and we need to -- instance of that family and we need to
-- --
-- (1) create a coercion that identifies the family instance type and the -- (1) create a coercion that identifies the family instance type and the
-- representation type from Step (1); ie, it is of the form -- 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, -- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
-- `F' the family tycon and `R' the (derived) representation tycon, -- `F' the family tycon and `R' the (derived) representation tycon,
-- and -- and
-- (2) produce a `AlgTyConParent' value containing the parent and coercion -- (2) produce a `TyConParent' value containing the parent and coercion
-- information. -- information.
-- --
parentInfo Nothing rep_tycon = mkParentInfo :: Maybe (TyCon, [Type])
-> Name -> [TyVar]
-> TyCon
-> TcRnIf m n TyConParent
mkParentInfo Nothing _ _ _ =
return NoParentTyCon return NoParentTyCon
parentInfo (Just (family, instTys)) rep_tycon = mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
do { -- Create the coercion do { -- Create the coercion
; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
; let co_tycon = mkDataInstCoercion co_tycon_name tvs ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
family instTys rep_tycon family instTys rep_tycon
; return $ FamilyTyCon family instTys co_tycon ; return $ FamilyTyCon family instTys co_tycon
} }
------------------------------------------------------ ------------------------------------------------------
mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon mkAbstractTyConRhs = AbstractTyCon
......
...@@ -383,7 +383,9 @@ tcIfaceDecl ignore_prags ...@@ -383,7 +383,9 @@ tcIfaceDecl ignore_prags
; rhs_tyki <- tcIfaceType rdr_rhs_ty ; rhs_tyki <- tcIfaceType rdr_rhs_ty
; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
else SynonymTyCon rhs_tyki 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 tcIfaceDecl ignore_prags
......
...@@ -69,7 +69,7 @@ import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) ...@@ -69,7 +69,7 @@ import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind ) import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName, mkTupleTyCon, mkAlgTyCon, tyConName,
AlgTyConParent(NoParentTyCon) ) TyConParent(NoParentTyCon) )
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed,
StrictnessMark(..) ) StrictnessMark(..) )
......
...@@ -650,7 +650,7 @@ newDFunName clas (ty:_) loc ...@@ -650,7 +650,7 @@ newDFunName clas (ty:_) loc
newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\end{code} \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 *external* name, like otber top-level names, and hence must be made with
newGlobalBinder. newGlobalBinder.
......
...@@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl) ...@@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl)
tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error 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 -> = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for a synonym do { -- check that the family declaration is for a synonym
unless (isSynTyCon family) $ unless (isSynTyCon family) $
...@@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {}) ...@@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {})
; t_typats <- mappM tcHsKindedType k_typats ; t_typats <- mappM tcHsKindedType k_typats
; t_rhs <- tcHsKindedType k_rhs ; t_rhs <- tcHsKindedType k_rhs
-- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs -- (3) construct representation tycon
; return Nothing -- !!!TODO: need TyThing for indexed synonym ; 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, tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
tcdCons = cons}) tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family -> = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
...@@ -300,6 +306,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ...@@ -300,6 +306,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
; t_typats <- mappM tcHsKindedType k_typats ; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt ; stupid_theta <- tcHsKindedContext k_ctxt
-- (3) construct representation tycon
; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
; tycon <- fixM (\ tycon -> do ; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs)) { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
...@@ -587,12 +594,15 @@ tcSynDecls (decl : decls) ...@@ -587,12 +594,15 @@ tcSynDecls (decl : decls)
; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
; return (syn_tc : syn_tcs) } ; return (syn_tc : syn_tcs) }
-- "type"
tcSynDecl tcSynDecl
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= tcTyVarBndrs tvs $ \ tvs' -> do = tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "tcd1" <+> ppr tc_name) { traceTc (text "tcd1" <+> ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty ; 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] tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
...@@ -614,7 +624,8 @@ tcTyClDecl1 _calc_isrec ...@@ -614,7 +624,8 @@ tcTyClDecl1 _calc_isrec
-- Check that we don't use families without -findexed-types -- Check that we don't use families without -findexed-types
; checkTc idx_tys $ badFamInstDecl tc_name ; 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 -- "newtype family" or "data family" declaration
...@@ -639,7 +650,7 @@ tcTyClDecl1 _calc_isrec ...@@ -639,7 +650,7 @@ tcTyClDecl1 _calc_isrec
; return [ATyCon tycon] ; return [ATyCon tycon]
} }
-- "newtype", "data", "newtype instance", "data instance" -- "newtype" and "data"
tcTyClDecl1 calc_isrec tcTyClDecl1 calc_isrec
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
......
...@@ -25,7 +25,7 @@ module Coercion ( ...@@ -25,7 +25,7 @@ module Coercion (
mkSymCoercion, mkTransCoercion, mkSymCoercion, mkTransCoercion,
mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion, mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion,
mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion, mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
mkNewTypeCoercion, mkDataInstCoercion, mkAppsCoercion, mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
splitNewTypeRepCo_maybe, decomposeCo, splitNewTypeRepCo_maybe, decomposeCo,
...@@ -294,18 +294,18 @@ mkNewTypeCoercion name tycon tvs rhs_ty ...@@ -294,18 +294,18 @@ mkNewTypeCoercion name tycon tvs rhs_ty
rule args = ASSERT( co_con_arity == length args ) rule args = ASSERT( co_con_arity == length args )
(TyConApp tycon args, substTyWith tvs args rhs_ty) (TyConApp tycon args, substTyWith tvs args rhs_ty)
-- Coercion identifying a data/newtype representation type and its family -- Coercion identifying a data/newtype/synonym representation type and its
-- instance. It has the form `Co tvs :: F ts :=: R tvs', where `Co' is the -- family instance. It has the form `Co tvs :: F ts :=: R tvs', where `Co' is
-- coercion tycon built here, `F' the family tycon and `R' the (derived) -- the coercion tycon built here, `F' the family tycon and `R' the (derived)
-- representation tycon. -- representation tycon.
-- --
mkDataInstCoercion :: Name -- unique name for the coercion tycon mkFamInstCoercion :: Name -- unique name for the coercion tycon
-> [TyVar] -- type parameters of the coercion (`tvs') -> [TyVar] -- type parameters of the coercion (`tvs')
-> TyCon -- family tycon (`F') -> TyCon -- family tycon (`F')
-> [Type] -- type instance (`ts') -> [Type] -- type instance (`ts')
-> TyCon -- representation tycon (`R') -> TyCon -- representation tycon (`R')
-> TyCon -- => coercion tycon (`Co') -> TyCon -- => coercion tycon (`Co')
mkDataInstCoercion name tvs family instTys rep_tycon mkFamInstCoercion name tvs family instTys rep_tycon
= mkCoercionTyCon name coArity rule = mkCoercionTyCon name coArity rule
where where
coArity = length tvs coArity = length tvs
......
...@@ -51,7 +51,7 @@ data FamInst ...@@ -51,7 +51,7 @@ data FamInst
-- Used for "rough matching"; same idea as for class instances -- Used for "rough matching"; same idea as for class instances
, fi_tcs :: [Maybe Name] -- Top of type args , 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 -- Used for "proper matching"; ditto
, fi_tvs :: TyVarSet -- Template tyvars for full match , fi_tvs :: TyVarSet -- Template tyvars for full match
......
...@@ -13,7 +13,7 @@ module TyCon( ...@@ -13,7 +13,7 @@ module TyCon(
tyConPrimRep, tyConPrimRep,
AlgTyConRhs(..), visibleDataCons, AlgTyConRhs(..), visibleDataCons,
AlgTyConParent(..), TyConParent(..),
SynTyConRhs(..), SynTyConRhs(..),
isFunTyCon, isUnLiftedTyCon, isProductTyCon, isFunTyCon, isUnLiftedTyCon, isProductTyCon,
...@@ -125,7 +125,7 @@ data TyCon ...@@ -125,7 +125,7 @@ data TyCon
hasGenerics :: Bool, -- True <=> generic to/from functions are available hasGenerics :: Bool, -- True <=> generic to/from functions are available
-- (in the exports of the data type's source module) -- (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 -- derived tycons representing classes
-- or family instances, respectively. -- or family instances, respectively.
} }
...@@ -149,7 +149,12 @@ data TyCon ...@@ -149,7 +149,12 @@ data TyCon
tyConTyVars :: [TyVar], -- Bound tyvars 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 | PrimTyCon { -- Primitive types; cannot be defined in Haskell
...@@ -262,12 +267,13 @@ visibleDataCons OpenTyCon {} = [] ...@@ -262,12 +267,13 @@ visibleDataCons OpenTyCon {} = []
visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (DataTyCon{ data_cons = cs }) = cs
visibleDataCons (NewTyCon{ data_con = c }) = [c] visibleDataCons (NewTyCon{ data_con = c }) = [c]
-- Both type classes as well as data/newtype family instances imply implicit -- Both type classes as well as family instances imply implicit type
-- type constructors. These implicit type constructors refer to their parent -- constructors. These implicit type constructors refer to their parent
-- structure (ie, the class or family from which they derive) using a type of -- 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. = NoParentTyCon -- An ordinary type constructor has no parent.
| ClassTyCon -- Type constructors representing a class dictionary. | ClassTyCon -- Type constructors representing a class dictionary.
...@@ -498,14 +504,15 @@ mkPrimTyCon' name kind arity rep is_unlifted ...@@ -498,14 +504,15 @@ mkPrimTyCon' name kind arity rep is_unlifted
tyConExtName = Nothing tyConExtName = Nothing
} }
mkSynTyCon name kind tyvars rhs mkSynTyCon name kind tyvars rhs parent
= SynTyCon { = SynTyCon {
tyConName = name, tyConName = name,
tyConUnique = nameUnique name, tyConUnique = nameUnique name,
tyConKind = kind, tyConKind = kind,
tyConArity = length tyvars, tyConArity = length tyvars,
tyConTyVars = tyvars, tyConTyVars = tyvars,
synTcRhs = rhs synTcRhs = rhs,
synTcParent = parent
} }
mkCoercionTyCon name arity kindRule mkCoercionTyCon name arity kindRule
...@@ -860,17 +867,22 @@ tyConClass_maybe other_tycon = Nothing ...@@ -860,17 +867,22 @@ tyConClass_maybe other_tycon = Nothing
isFamInstTyCon :: TyCon -> Bool isFamInstTyCon :: TyCon -> Bool
isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True
isFamInstTyCon other_tycon = False isFamInstTyCon other_tycon = False
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =
Just (fam, instTys) Just (fam, instTys)
tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) =
Just (fam, instTys)
tyConFamInst_maybe other_tycon = tyConFamInst_maybe other_tycon =
Nothing Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) =
Just coe Just coe
tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) =
Just coe
tyConFamilyCoercion_maybe other_tycon = tyConFamilyCoercion_maybe other_tycon =
Nothing Nothing
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment