Commit 0cb269be authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Get of fam inst index in ifaces

Mon Sep 18 19:40:42 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Get of fam inst index in ifaces
  Fri Sep  8 16:31:26 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Get of fam inst index in ifaces
    - Removes the explicit index to get unique names for derived tycons for family
      instances again, following a suggestion by SPJ.
    - We now derive the coercion tycon name from the name of the representation 
      tycon, which is in the iface anyways.
    
    *** WARNING: Change of interface file format! ***
    ***          Recompile from scratch!          ***
parent 129e40f1
......@@ -443,6 +443,7 @@ mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
mkNewTyCoOcc = mk_simple_deriv tcName "Co"
mkInstTyCoOcc = mk_simple_deriv tcName "Co" -- derived from rep ty
-- Generic derivable classes
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
......@@ -478,24 +479,15 @@ mkLocalOcc uniq occ
-- that need encoding (e.g. 'z'!)
\end{code}
\begin{code}
Derive a name for the representation type constructor of a data/newtype
instance.
-- Derive a name for the representation type constructor of a data/newtype
-- instance.
--
\begin{code}
mkInstTyTcOcc :: Int -- Index
-> OccName -- Local name (e.g. "Map")
-> OccName -- Family name (e.g. "Map")
-> OccName -- Nice unique version (":R23Map")
mkInstTyTcOcc index occ
= mk_deriv varName (":R" ++ show index) (occNameString occ)
-- Derive a name for the coercion of a data/newtype instance.
--
mkInstTyCoOcc :: Int -- Index
-> OccName -- Local name (e.g. "Map")
-> OccName -- Nice unique version (":Co23Map")
mkInstTyCoOcc index occ
= mk_deriv varName (":Co" ++ show index) (occNameString occ)
\end{code}
\begin{code}
......
......@@ -69,9 +69,7 @@ buildAlgTyCon :: Name -> [TyVar]
-> RecFlag
-> Bool -- True <=> want generics functions
-> Bool -- True <=> was declared in GADT syntax
-> Maybe (TyCon, [Type],
Int) -- Just (family, tys, index)
-- <=> instance of `family' at `tys'
-> Maybe (TyCon, [Type]) -- family instance if applicable
-> TcRnIf m n TyCon
buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
......@@ -79,8 +77,8 @@ 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
{ (final_name, parent) <- maybeComputeFamilyInfo mb_family tycon_rec
; let { tycon = mkAlgTyCon final_name kind tvs stupid_theta rhs
{ parent <- parentInfo mb_family 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
; fields = mkTyConSelIds tycon rhs
......@@ -91,31 +89,24 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
}
where
-- If a family tycon with instance types is given, the current tycon is an
-- instance of that family and we have to perform three extra tasks:
-- instance of that family and we need to
--
-- (1) The instance tycon (representing the family at a particular type
-- instance) need to get a new, derived name - we may not reuse the
-- family name.
-- (2) 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
-- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
-- `F' the family tycon and `R' the (derived) representation tycon.
-- (3) Produce a `AlgTyConParent' value containing the parent and coercion
-- `F' the family tycon and `R' the (derived) representation tycon,
-- and
-- (2) produce a `AlgTyConParent' value containing the parent and coercion
-- information.
--
maybeComputeFamilyInfo Nothing rep_tycon =
return (tc_name, NoParentTyCon)
maybeComputeFamilyInfo (Just (family, instTys, index)) rep_tycon =
do { -- (1) New, derived name for the instance tycon
; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc index)
-- (2) Create the coercion.
; co_tycon_name <- newImplicitBinder tc_name (mkInstTyCoOcc index)
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
-- (3) Produce parent information.
; return (final_name, FamilyTyCon family instTys co_tycon index)
; return $ FamilyTyCon family instTys co_tycon
}
......
......@@ -87,8 +87,7 @@ data IfaceDecl
-- current compilation unit
ifFamInst :: Maybe -- Just _ <=> instance of fam
(IfaceTyCon, -- Family tycon
[IfaceType], -- Instance types
Int ) -- Unique index for naming
[IfaceType]) -- Instance types
}
| IfaceSyn { ifName :: OccName, -- Type constructor
......@@ -284,10 +283,9 @@ pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
pprFamily Nothing = ptext SLIT("FamilyInstance: none")
pprFamily (Just (fam, tys, index)) = ptext SLIT("FamilyInstance:") <+>
ppr fam <+> hsep (map ppr tys) <+>
brackets (ppr index)
pprFamily Nothing = ptext SLIT("FamilyInstance: none")
pprFamily (Just (fam, tys)) = ptext SLIT("FamilyInstance:") <+>
ppr fam <+> hsep (map ppr tys)
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
......@@ -556,10 +554,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
Nothing `eqIfTc_fam` Nothing = Equal
(Just (fam1, tys1, co1)) `eqIfTc_fam` (Just (fam2, tys2, co2)) =
fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 &&& bool (co1 == co2)
_ `eqIfTc_fam` _ = NotEqual
Nothing `eqIfTc_fam` Nothing = Equal
(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
_ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
......
......@@ -409,9 +409,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifaceDeclSubBndrs _other = []
-- coercion for data/newtype family instances
famInstCo Nothing baseOcc = []
famInstCo (Just (_, _, index)) baseOcc = [mkInstTyTcOcc index baseOcc,
mkInstTyCoOcc index baseOcc]
famInstCo Nothing baseOcc = []
famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
\end{code}
......
......@@ -191,7 +191,7 @@ import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
tyConFamInst_maybe, tyConFamInstIndex )
tyConFamInst_maybe )
import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, dataConUnivTyVars,
dataConExTyVars, dataConEqSpec, dataConTheta,
......@@ -1036,8 +1036,7 @@ tyThingToIfaceDecl ext (ATyCon tycon)
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
(tyConFamInstIndex tycon) }
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
......@@ -1088,9 +1087,9 @@ tyThingToIfaceDecl ext (ATyCon tycon)
to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
famInstToIface Nothing _ = Nothing
famInstToIface (Just (famTyCon, instTys)) index =
Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys, index)
famInstToIface Nothing = Nothing
famInstToIface (Just (famTyCon, instTys)) =
Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys)
tyThingToIfaceDecl ext (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
......
......@@ -371,11 +371,11 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
{ stupid_theta <- tcIfaceCtxt ctxt
; famInst <-
case mb_family of
Nothing -> return Nothing
Just (fam, tys, index) ->
Nothing -> return Nothing
Just (fam, tys) ->
do { famTyCon <- tcIfaceTyCon fam
; insttys <- mapM tcIfaceType tys
; return $ Just (famTyCon, insttys, index)
; return $ Just (famTyCon, insttys)
}
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
......
......@@ -38,7 +38,7 @@ module TcEnv(
topIdLvl,
-- New Ids
newLocalName, newDFunName
newLocalName, newDFunName, newFamInstTyConName
) where
#include "HsVersions.h"
......@@ -66,11 +66,13 @@ import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead )
import DataCon ( DataCon )
import TyCon ( TyCon )
import Class ( Class )
import Name ( Name, NamedThing(..), getSrcLoc, nameModule )
import Name ( Name, NamedThing(..), getSrcLoc, nameModule,
nameOccName )
import PrelNames ( thFAKE )
import NameEnv
import OccName ( mkDFunOcc, occNameString )
import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) )
import OccName ( mkDFunOcc, occNameString, mkInstTyTcOcc )
import HscTypes ( extendTypeEnvList, lookupType, TyThing(..),
ExternalPackageState(..) )
import SrcLoc ( SrcLoc, Located(..) )
import Outputable
\end{code}
......@@ -611,6 +613,19 @@ 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
*external* name, like otber top-level names, and hence must be made with
newGlobalBinder.
\begin{code}
newFamInstTyConName :: Name -> SrcLoc -> TcM Name
newFamInstTyConName tc_name loc
= do { index <- nextDFunIndex
; mod <- getModule
; let occ = nameOccName tc_name
; newGlobalBinder mod (mkInstTyTcOcc index occ) Nothing loc }
\end{code}
%************************************************************************
%* *
......
......@@ -25,7 +25,8 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendGlobalEnv, tcExtendKindEnv,
tcExtendKindEnvTvs, newFamInstTyConName,
tcExtendRecEnv, tcLookupTyVar, InstInfo )
import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
......@@ -66,7 +67,8 @@ import Monad ( unless )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan,
srcSpanStart )
import ListSetOps ( equivClasses, minusList )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
......@@ -327,7 +329,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
; index <- nextDFunIndex -- to generate unique names
; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
tycon t_tvs))
......@@ -335,11 +337,10 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
; tc_rhs <-
case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType ->
ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
False h98_syntax (Just (family, t_typats, index))
NewType -> ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
False h98_syntax (Just (family, t_typats))
-- 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
......
......@@ -50,7 +50,6 @@ module TyCon(
tyConArity,
isClassTyCon, tyConClass_maybe,
isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
tyConFamInstIndex,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
......@@ -275,9 +274,6 @@ data AlgTyConParent = -- An ordinary type constructor has no parent.
TyCon -- a *coercion* identifying
-- the representation type
-- with the type instance
Int -- index to generate unique
-- name (needed here to put
-- into iface)
data SynTyConRhs
= OpenSynTyCon Kind -- Type family: *result* kind given
......@@ -817,25 +813,20 @@ 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
isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
isFamInstTyCon other_tycon = False
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _ _}) =
tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =
Just (fam, instTys)
tyConFamInst_maybe ther_tycon =
tyConFamInst_maybe ther_tycon =
Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe _}) =
tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) =
Just coe
tyConFamilyCoercion_maybe ther_tycon =
tyConFamilyCoercion_maybe ther_tycon =
Nothing
tyConFamInstIndex :: TyCon -> Int
tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index
tyConFamInstIndex _ =
panic "tyConFamInstIndex"
\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