Commit 52ddeaae authored by Simon Marlow's avatar Simon Marlow
Browse files

Change the code generated for deriving Typeable, to match the changes

to the Typeable library.  We now generate an MD5 hash of the
fully-qualified TyCon name at compile time.
parent e4f94847
......@@ -282,7 +282,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE :: Module
......@@ -323,7 +323,8 @@ gHC_FLOAT = mkBaseModule (fsLit "GHC.Float")
gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler")
sYSTEM_IO = mkBaseModule (fsLit "System.IO")
dYNAMIC = mkBaseModule (fsLit "Data.Dynamic")
tYPEABLE = mkBaseModule (fsLit "Data.Typeable")
tYPEABLE = mkBaseModule (fsLit "Data.Typeable")
tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")
gENERICS = mkBaseModule (fsLit "Data.Data")
dOTNET = mkBaseModule (fsLit "GHC.Dotnet")
rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")
......@@ -546,10 +547,10 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString")
showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
typeOf_RDR, mkTypeRep_RDR, mkTyConRep_RDR :: RdrName
typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
typeOf_RDR = varQual_RDR tYPEABLE (fsLit "typeOf")
mkTypeRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp")
mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
mkTyConApp_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
......
......@@ -52,13 +52,19 @@ import TysWiredIn
import Type
import TypeRep
import VarSet
import Module
import State
import Util
import MonadUtils
import Outputable
import FastString
import Bag
import Data.List ( partition, intersperse )
import Binary hiding (get,put)
import Fingerprint
import Constants
import System.IO.Unsafe ( unsafePerformIO )
import Data.List ( partition, intersperse )
\end{code}
\begin{code}
......@@ -1161,8 +1167,9 @@ From the data type
we generate
instance Typeable2 T where
typeOf2 _ = mkTyConApp (mkTyConRep "T") []
instance Typeable2 T where
typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low>
<pkg> <module> "T") []
We are passed the Typeable2 class as well as T
......@@ -1173,9 +1180,33 @@ gen_Typeable_binds loc tycon
mk_easy_FunBind loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
(nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
where
tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
tycon_name = tyConName tycon
modl = nameModule tycon_name
pkg = modulePackageId modl
modl_fs = moduleNameFS (moduleName modl)
pkg_fs = packageIdFS pkg
name_fs = occNameFS (nameOccName tycon_name)
tycon_rep = nlHsApps mkTyCon_RDR
(map nlHsLit [int64 high,
int64 low,
HsString pkg_fs,
HsString modl_fs,
HsString name_fs])
Fingerprint high low = unsafePerformIO $ -- ugh
computeFingerprint (error "gen_typeable_binds")
(unpackFS pkg_fs ++
unpackFS modl_fs ++
unpackFS name_fs)
int64
| wORD_SIZE == 4 = HsWord64Prim . fromIntegral
| otherwise = HsWordPrim . fromIntegral
mk_typeOf_RDR :: TyCon -> RdrName
-- Use the arity of the TyCon to make the right typeOfn function
......
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