Revert "Generate Typeable info at definition sites"

This reverts commit bef2f03e4d56d88a7e9752a7afd6a0a35616da6c.

This merge was botched

Also reverts haddock submodule.

2 files changed, 113 insertions, 222 deletions

diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 1afc6a9563..c30a43dd65 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/Data/Typeable.hs
@@ -58,7 +58,7 @@ module Data.Typeable
 
         -- * A canonical proxy type
         Proxy (..),
-
+        
         -- * Type representations
         TypeRep,        -- abstract, instance of: Eq, Show, Typeable
         typeRepFingerprint,
@@ -66,7 +66,6 @@ module Data.Typeable
         showsTypeRep,
 
         TyCon,          -- abstract, instance of: Eq, Show, Typeable
-                        -- For now don't export Module, to avoid name clashes
         tyConFingerprint,
         tyConString,
         tyConPackage,
@@ -88,7 +87,7 @@ module Data.Typeable
         typeRepArgs,    -- :: TypeRep -> [TypeRep]
   ) where
 
-import Data.Typeable.Internal
+import Data.Typeable.Internal hiding (mkTyCon)
 import Data.Type.Equality
 
 import Unsafe.Coerce
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 4379155c57..e35d794a62 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -25,34 +25,15 @@
 
 module Data.Typeable.Internal (
     Proxy (..),
+    TypeRep(..),
+    KindRep,
     Fingerprint(..),
-
-    -- * Typeable class
     typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
     Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
-
-    -- * Module
-    Module,  -- Abstract
-    moduleName, modulePackage,
-
-    -- * TyCon
-    TyCon,   -- Abstract
-    tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint,
-    mkTyCon3, mkTyCon3#,
-    rnfTyCon,
-
-    tcBool, tc'True, tc'False,
-    tcOrdering, tc'LT, tc'EQ, tc'GT,
-    tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
-    tcIO, tcSPEC, tcTyCon, tcModule,
-    tcCoercible, tcList, tcEq,
-    tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK,
-
-    funTc,  -- ToDo
-
-    -- * TypeRep
-    TypeRep(..), KindRep,
+    TyCon(..),
     typeRep,
+    mkTyCon,
+    mkTyCon3,
     mkTyConApp,
     mkPolyTyConApp,
     mkAppTy,
@@ -66,15 +47,19 @@ module Data.Typeable.Internal (
     typeRepFingerprint,
     rnfTypeRep,
     showsTypeRep,
+    tyConString,
+    rnfTyCon,
+    listTc, funTc,
     typeRepKinds,
-    typeSymbolTypeRep, typeNatTypeRep
+    typeNatTypeRep,
+    typeSymbolTypeRep
   ) where
 
 import GHC.Base
 import GHC.Word
 import GHC.Show
+import GHC.TypeLits
 import Data.Proxy
-import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' )
 
 import GHC.Fingerprint.Type
 import {-# SOURCE #-} GHC.Fingerprint
@@ -83,106 +68,9 @@ import {-# SOURCE #-} GHC.Fingerprint
    -- of Data.Typeable as much as possible so we can optimise the derived
    -- instances.
 
-#include "MachDeps.h"
-
-{- *********************************************************************
-*                                                                      *
-                The TyCon type
-*                                                                      *
-********************************************************************* -}
-
-modulePackage :: Module -> String
-modulePackage (Module p _) = trNameString p
-
-moduleName :: Module -> String
-moduleName (Module _ m) = trNameString m
-
-tyConPackage :: TyCon -> String
-tyConPackage (TyCon _ _ m _) = modulePackage m
-
-tyConModule :: TyCon -> String
-tyConModule (TyCon _ _ m _) = moduleName m
-
-tyConName :: TyCon -> String
-tyConName (TyCon _ _ _ n) = trNameString n
-
-trNameString :: TrName -> String
-trNameString (TrNameS s) = unpackCString# s
-trNameString (TrNameD s) = s
-
--- | Observe string encoding of a type representation
-{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-}
--- deprecated in 7.4
-tyConString :: TyCon   -> String
-tyConString = tyConName
-
-tyConFingerprint :: TyCon -> Fingerprint
-tyConFingerprint (TyCon hi lo _ _)
-  = Fingerprint (W64# hi) (W64# lo)
-
-mkTyCon3# :: Addr#       -- ^ package name
-          -> Addr#       -- ^ module name
-          -> Addr#       -- ^ the name of the type constructor
-          -> TyCon       -- ^ A unique 'TyCon' object
-mkTyCon3# pkg modl name
-  | Fingerprint (W64# hi) (W64# lo) <- fingerprint
-  = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name)
-  where
-    fingerprint :: Fingerprint
-    fingerprint = fingerprintString (unpackCString# pkg
-                                    ++ (' ': unpackCString# modl)
-                                    ++ (' ' : unpackCString# name))
-
-mkTyCon3 :: String       -- ^ package name
-         -> String       -- ^ module name
-         -> String       -- ^ the name of the type constructor
-         -> TyCon        -- ^ A unique 'TyCon' object
--- Used when the strings are dynamically allocated,
--- eg from binary deserialisation
-mkTyCon3 pkg modl name
-  | Fingerprint (W64# hi) (W64# lo) <- fingerprint
-  = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name)
-  where
-    fingerprint :: Fingerprint
-    fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name))
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon tc
-  | ('(':',':_) <- tyConName tc = True
-  | otherwise                   = False
-
--- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
---
--- @since 4.8.0.0
-rnfModule :: Module -> ()
-rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
-
-rnfTrName :: TrName -> ()
-rnfTrName (TrNameS _) = ()
-rnfTrName (TrNameD n) = rnfString n
-
-rnfTyCon :: TyCon -> ()
-rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n
-
-rnfString :: [Char] -> ()
-rnfString [] = ()
-rnfString (c:cs) = c `seq` rnfString cs
-
-
-{- *********************************************************************
-*                                                                      *
-                The TypeRep type
-*                                                                      *
-********************************************************************* -}
-
--- | A concrete representation of a (monomorphic) type.
--- 'TypeRep' supports reasonably efficient equality.
+-- | A concrete representation of a (monomorphic) type.  'TypeRep'
+-- supports reasonably efficient equality.
 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep]
-     -- NB: For now I've made this lazy so that it's easy to
-     -- optimise code that constructs and deconstructs TypeReps
-     -- perf/should_run/T9203 is a good example
-     -- Also note that mkAppTy does discards the fingerprint,
-     -- so it's a waste to compute it
 
 type KindRep = TypeRep
 
@@ -193,42 +81,56 @@ instance Eq TypeRep where
 instance Ord TypeRep where
   TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y
 
--- | Observe the 'Fingerprint' of a type representation
---
--- @since 4.8.0.0
-typeRepFingerprint :: TypeRep -> Fingerprint
-typeRepFingerprint (TypeRep fpr _ _ _) = fpr
 
--- | Applies a kind-polymorphic type constructor to a sequence of kinds and
--- types
+-- | An abstract representation of a type constructor.  'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon {
+   tyConFingerprint :: {-# UNPACK #-} !Fingerprint, -- ^ @since 4.8.0.0
+   tyConPackage :: String, -- ^ @since 4.5.0.0
+   tyConModule  :: String, -- ^ @since 4.5.0.0
+   tyConName    :: String  -- ^ @since 4.5.0.0
+ }
+
+instance Eq TyCon where
+  (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
+
+instance Ord TyCon where
+  (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
+
+----------------- Construction --------------------
+
+#include "MachDeps.h"
+
+-- mkTyCon is an internal function to make it easier for GHC to
+-- generate derived instances.  GHC precomputes the MD5 hash for the
+-- TyCon and passes it as two separate 64-bit values to mkTyCon.  The
+-- TyCon for a derived Typeable instance will end up being statically
+-- allocated.
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+mkTyCon high# low# pkg modl name
+  = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
+
+-- | Applies a polymorhic type constructor to a sequence of kinds and types
 mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
-{-# INLINE mkPolyTyConApp #-}
-mkPolyTyConApp tc kinds types
-  = TypeRep (fingerprintFingerprints sub_fps) tc kinds types
+mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] []
+mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types =
+  TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types
   where
-    !kt_fps = typeRepFingerprints kinds types
-    sub_fps = tyConFingerprint tc : kt_fps
+  arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ]
 
-typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint]
--- Builds no thunks
-typeRepFingerprints kinds types
-  = go1 [] kinds
-  where
-    go1 acc []     = go2 acc types
-    go1 acc (k:ks) = let !fp = typeRepFingerprint k
-                     in go1 (fp:acc) ks
-    go2 acc []     = acc
-    go2 acc (t:ts) = let !fp = typeRepFingerprint t
-                     in go2 (fp:acc) ts
-
--- | Applies a kind-monomorphic type constructor to a sequence of types
+-- | Applies a monomorphic type constructor to a sequence of types
 mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
 mkTyConApp tc = mkPolyTyConApp tc []
 
 -- | A special case of 'mkTyConApp', which applies the function
 -- type constructor to a pair of types.
 mkFunTy  :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkTyConApp tcFun [f,a]
+mkFunTy f a = mkTyConApp funTc [f,a]
 
 -- | Splits a type constructor application.
 -- Note that if the type construcotr is polymorphic, this will
@@ -248,12 +150,11 @@ splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs)
 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
 funResultTy trFun trArg
   = case splitTyConApp trFun of
-      (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2
+      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
       _ -> Nothing
 
 -- | Adds a TypeRep argument to a TypeRep.
 mkAppTy :: TypeRep -> TypeRep -> TypeRep
-{-# INLINE mkAppTy #-}
 mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
    -- Notice that we call mkTyConApp to construct the fingerprint from tc and
    -- the arg fingerprints.  Simply combining the current fingerprint with
@@ -261,6 +162,20 @@ mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
    -- ensure that a TypeRep of the same shape has the same fingerprint!
    -- See Trac #5962
 
+-- | Builds a 'TyCon' object representing a type constructor.  An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
+--
+
+--
+mkTyCon3 :: String       -- ^ package name
+         -> String       -- ^ module name
+         -> String       -- ^ the name of the type constructor
+         -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+  TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
+
 ----------------- Observation ---------------------
 
 -- | Observe the type constructor of a type representation
@@ -275,12 +190,16 @@ typeRepArgs (TypeRep _ _ _ tys) = tys
 typeRepKinds :: TypeRep -> [KindRep]
 typeRepKinds (TypeRep _ _ ks _) = ks
 
+-- | Observe string encoding of a type representation
+{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4
+tyConString :: TyCon   -> String
+tyConString = tyConName
 
-{- *********************************************************************
-*                                                                      *
-                The Typeable class
-*                                                                      *
-********************************************************************* -}
+-- | Observe the 'Fingerprint' of a type representation
+--
+-- @since 4.8.0.0
+typeRepFingerprint :: TypeRep -> Fingerprint
+typeRepFingerprint (TypeRep fpr _ _ _) = fpr
 
 -------------------------------------------------------------
 --
@@ -354,8 +273,8 @@ instance Show TypeRep where
   showsPrec p (TypeRep _ tycon kinds tys) =
     case tys of
       [] -> showsPrec p tycon
-      [x]   | tycon == tcList -> showChar '[' . shows x . showChar ']'
-      [a,r] | tycon == tcFun  -> showParen (p > 8) $
+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
+      [a,r] | tycon == funTc  -> showParen (p > 8) $
                                  showsPrec 9 a .
                                  showString " -> " .
                                  showsPrec 8 r
@@ -369,6 +288,13 @@ instance Show TypeRep where
 showsTypeRep :: TypeRep -> ShowS
 showsTypeRep = shows
 
+instance Show TyCon where
+  showsPrec _ t = showString (tyConName t)
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
+isTupleTyCon _                         = False
+
 -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
 --
 -- @since 4.8.0.0
@@ -378,6 +304,15 @@ rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
     go [] = ()
     go (x:xs) = rnfTypeRep x `seq` go xs
 
+-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
+--
+-- @since 4.8.0.0
+rnfTyCon :: TyCon -> ()
+rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn
+  where
+    go [] = ()
+    go (x:xs) = x `seq` go xs
+
 -- Some (Show.TypeRep) helpers:
 
 showArgs :: Show a => ShowS -> [a] -> ShowS
@@ -390,68 +325,13 @@ showTuple args = showChar '('
                . showArgs (showChar ',') args
                . showChar ')'
 
-{- *********************************************************
-*                                                          *
-*            TyCon definitions for GHC.Types               *
-*                                                          *
-********************************************************* -}
-
-mkGhcTypesTyCon :: Addr# -> TyCon
-{-# INLINE mkGhcTypesTyCon #-}
-mkGhcTypesTyCon name = mkTyCon3# "ghc-prim"# "GHC.Types"# name
-
-tcBool, tc'True, tc'False,
-  tcOrdering, tc'GT, tc'EQ, tc'LT,
-  tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
-  tcIO, tcSPEC, tcTyCon, tcModule,
-  tcCoercible, tcEq, tcList :: TyCon
-
-tcBool      = mkGhcTypesTyCon "Bool"#      -- Bool is promotable
-tc'True     = mkGhcTypesTyCon "'True"#
-tc'False    = mkGhcTypesTyCon "'False"#
-tcOrdering  = mkGhcTypesTyCon "Ordering"#  -- Ordering is promotable
-tc'GT       = mkGhcTypesTyCon "'GT"#
-tc'EQ       = mkGhcTypesTyCon "'EQ"#
-tc'LT       = mkGhcTypesTyCon "'LT"#
-
--- None of the rest are promotable (see TysWiredIn)
-tcChar      = mkGhcTypesTyCon "Char"#
-tcInt       = mkGhcTypesTyCon "Int"#
-tcWord      = mkGhcTypesTyCon "Word"#
-tcFloat     = mkGhcTypesTyCon "Float"#
-tcDouble    = mkGhcTypesTyCon "Double"#
-tcSPEC      = mkGhcTypesTyCon "SPEC"#
-tcIO        = mkGhcTypesTyCon "IO"#
-tcTyCon     = mkGhcTypesTyCon "TyCon"#
-tcModule    = mkGhcTypesTyCon "Module"#
-tcCoercible = mkGhcTypesTyCon "Coercible"#
-
-tcFun       = mkGhcTypesTyCon "->"#
-tcList      = mkGhcTypesTyCon "[]"#   -- Type rep for the list type constructor
-tcEq        = mkGhcTypesTyCon "~"#    -- Type rep for the (~) type constructor
-
-tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK :: TyCon
-tcLiftedKind   = mkGhcTypesTyCon "*"#
-tcUnliftedKind = mkGhcTypesTyCon "#"#
-tcOpenKind     = mkGhcTypesTyCon "#"#
-tcBOX          = mkGhcTypesTyCon "BOX"#
-tcAnyK         = mkGhcTypesTyCon "AnyK"#
-tcConstraint   = mkGhcTypesTyCon "Constraint"#
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
 
 funTc :: TyCon
-funTc = tcFun   -- Legacy
-
-{- *********************************************************
-*                                                          *
-*       TyCon/TypeRep definitions for type literals        *
-*              (Symbol and Nat)                            *
-*                                                          *
-********************************************************* -}
+funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
 
 
-mkTypeLitTyCon :: String -> TyCon
-mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name
-
 -- | Used to make `'Typeable' instance for things of kind Nat
 typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
 typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
@@ -462,5 +342,17 @@ typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
 
 -- | An internal function, to make representations for type literals.
 typeLitTypeRep :: String -> TypeRep
-typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) []
+typeLitTypeRep nm = rep
+    where
+    rep = mkTyConApp tc []
+    tc = TyCon
+           { tyConFingerprint = fingerprintString (mk pack modu nm)
+           , tyConPackage  = pack
+           , tyConModule   = modu
+           , tyConName     = nm
+           }
+    pack = "base"
+    modu = "GHC.TypeLits"
+    mk a b c = a ++ " " ++ b ++ " " ++ c
+