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"
-- 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}
-> 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
= 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
}
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
}
-- 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
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
-- 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) &&&
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}
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,
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,
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
{ 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
topIdLvl,
-- New Ids
- newLocalName, newDFunName
+ newLocalName, newDFunName, newFamInstTyConName
) where
#include "HsVersions.h"
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}
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}
+
%************************************************************************
%* *
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 )
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,
; 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))
; 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
tyConArity,
isClassTyCon, tyConClass_maybe,
isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
- tyConFamInstIndex,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
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
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}
projects / ghc-hetmet.git / commitdiff