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

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
\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki _)
= mkSynTyCon name kind tvs rhs
where
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
buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
= mkSynTyCon name kind tvs rhs
where
kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
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 =
-- 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
parentInfo (Just (family, instTys)) rep_tycon =
mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
do { -- Create the coercion
; 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
; return $ FamilyTyCon family instTys co_tycon
}
------------------------------------------------------
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
......
......@@ -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
......
......@@ -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(..) )
......
......@@ -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.
......
......@@ -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})
......
......@@ -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
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')
mkDataInstCoercion name tvs family instTys rep_tycon
mkFamInstCoercion name tvs family instTys rep_tycon
= mkCoercionTyCon name coArity rule
where
coArity = length tvs
......
......@@ -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
......
......@@ -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.
......@@ -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}
......
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