content: {-# LANGUAGE Unsafe #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Data.Typeable.Internal
  -- Copyright   :  (c) The University of Glasgow, CWI 2001--2011
  -- License     :  BSD-style (see the file libraries/base/LICENSE)
  -- 
  -- The representations of the types TyCon and TypeRep, and the
  -- function mkTyCon which is used by derived instances of Typeable to
  -- construct a TyCon.
  --
  -----------------------------------------------------------------------------
  
  {-# LANGUAGE CPP
             , NoImplicitPrelude
             , OverlappingInstances
             , ScopedTypeVariables
             , FlexibleInstances
             , MagicHash #-}
  #ifdef __GLASGOW_HASKELL__
  {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
  #endif
  
  module Data.Typeable.Internal (
      TypeRep(..),
      TyCon(..),
      mkTyCon,
      mkTyCon3,
      mkTyConApp,
      mkAppTy,
      typeRepTyCon,
      typeOfDefault,
      typeOf1Default,
      typeOf2Default,
      typeOf3Default,
      typeOf4Default,
      typeOf5Default,
      typeOf6Default,
      Typeable(..),
      Typeable1(..),
      Typeable2(..),
      Typeable3(..),
      Typeable4(..),
      Typeable5(..),
      Typeable6(..),
      Typeable7(..),
      mkFunTy,
      splitTyConApp,
      funResultTy,
      typeRepArgs,
      showsTypeRep,
      tyConString,
  #if defined(__GLASGOW_HASKELL__)
      listTc, funTc
  #endif
    ) where
  
  import GHC.Base
  import GHC.Word
  import GHC.Show
  import GHC.Err          (undefined)
  import Data.Maybe
  import Data.List
  import GHC.Num
  import GHC.Real
  import GHC.IORef
  import GHC.IOArray
  import GHC.MVar
  import GHC.ST           ( ST )
  import GHC.STRef        ( STRef )
  import GHC.Ptr          ( Ptr, FunPtr )
  import GHC.Stable
  import GHC.Arr          ( Array, STArray )
  import Data.Int
  
  import GHC.Fingerprint.Type
  import {-# SOURCE #-} GHC.Fingerprint
     -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
     -- Better to break the loop here, because we want non-SOURCE imports
     -- of Data.Typeable as much as possible so we can optimise the derived
     -- instances.
  
  -- | A concrete representation of a (monomorphic) type.  'TypeRep'
  -- supports reasonably efficient equality.
  data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
  
  -- Compare keys for equality
  instance Eq TypeRep where
    (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
  
  instance Ord TypeRep where
    (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
  
  -- | An abstract representation of a type constructor.  'TyCon' objects can
  -- be built using 'mkTyCon'.
  data TyCon = TyCon {
     tyConHash    :: {-# UNPACK #-} !Fingerprint,
     tyConPackage :: String,
     tyConModule  :: String,
     tyConName    :: String
   }
  
  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 type constructor to a sequence of types
  mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
  mkTyConApp tc@(TyCon tc_k _ _ _) []
    = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
                         -- end up here, and it helps generate smaller
                         -- code for derived Typeable.
  mkTyConApp tc@(TyCon tc_k _ _ _) args
    = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
    where
      arg_ks = [k | TypeRep k _ _ <- args]
  
  -- | A special case of 'mkTyConApp', which applies the function 
  -- type constructor to a pair of types.
  mkFunTy  :: TypeRep -> TypeRep -> TypeRep
  mkFunTy f a = mkTyConApp funTc [f,a]
  
  -- | Splits a type constructor application
  splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
  splitTyConApp (TypeRep _ tc trs) = (tc,trs)
  
  -- | Applies a type to a function type.  Returns: @'Just' u@ if the
  -- first argument represents a function of type @t -> u@ and the
  -- second argument represents a function of type @t@.  Otherwise,
  -- returns 'Nothing'.
  funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
  funResultTy trFun trArg
    = case splitTyConApp trFun of
        (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
        _ -> Nothing
  
  -- | Adds a TypeRep argument to a TypeRep.
  mkAppTy :: TypeRep -> TypeRep -> TypeRep
  mkAppTy (TypeRep tr_k tc trs) arg_tr
    = let (TypeRep arg_k _ _) = arg_tr
       in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])
  
  -- | 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 (unwords [pkg, modl, name])) pkg modl name
  
  ----------------- Observation ---------------------
  
  -- | Observe the type constructor of a type representation
  typeRepTyCon :: TypeRep -> TyCon
  typeRepTyCon (TypeRep _ tc _) = tc
  
  -- | Observe the argument types of a type representation
  typeRepArgs :: TypeRep -> [TypeRep]
  typeRepArgs (TypeRep _ _ args) = args
  
  -- | Observe string encoding of a type representation
  {-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-}
  tyConString :: TyCon   -> String
  tyConString = tyConName
  
  -------------------------------------------------------------
  --
  --      The Typeable class and friends
  --
  -------------------------------------------------------------
  
  {- Note [Memoising typeOf]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  IMPORTANT: we don't want to recalculate the type-rep once per
  call to the dummy argument.  This is what went wrong in Trac #3245
  So we help GHC by manually keeping the 'rep' *outside* the value 
  lambda, thus
      
      typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
      typeOfDefault = \_ -> rep
        where
          rep = typeOf1 (undefined :: t a) `mkAppTy` 
                typeOf  (undefined :: a)
  
  Notice the crucial use of scoped type variables here!
  -}
  
  -- | The class 'Typeable' allows a concrete representation of a type to
  -- be calculated.
  class Typeable a where
    typeOf :: a -> TypeRep
    -- ^ Takes a value of type @a@ and returns a concrete representation
    -- of that type.  The /value/ of the argument should be ignored by
    -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
    -- the argument.
  
  -- | Variant for unary type constructors
  class Typeable1 t where
    typeOf1 :: t a -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable' instance from any 'Typeable1' instance.
  typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
  typeOfDefault = \_ -> rep
   where
     rep = typeOf1 (undefined :: t a) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable' instance from any 'Typeable1' instance.
  typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
  typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a -> a
     argType = undefined
  #endif
  
  -- | Variant for binary type constructors
  class Typeable2 t where
    typeOf2 :: t a b -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
  typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
  typeOf1Default = \_ -> rep 
   where
     rep = typeOf2 (undefined :: t a b) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
  typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
  typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b -> a
     argType = undefined
  #endif
  
  -- | Variant for 3-ary type constructors
  class Typeable3 t where
    typeOf3 :: t a b c -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
  typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
  typeOf2Default = \_ -> rep 
   where
     rep = typeOf3 (undefined :: t a b c) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
  typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
  typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b c -> a
     argType = undefined
  #endif
  
  -- | Variant for 4-ary type constructors
  class Typeable4 t where
    typeOf4 :: t a b c d -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
  typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
  typeOf3Default = \_ -> rep
   where
     rep = typeOf4 (undefined :: t a b c d) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
  typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
  typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b c d -> a
     argType = undefined
  #endif
     
  -- | Variant for 5-ary type constructors
  class Typeable5 t where
    typeOf5 :: t a b c d e -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
  typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
  typeOf4Default = \_ -> rep 
   where
     rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
  typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
  typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b c d e -> a
     argType = undefined
  #endif
  
  -- | Variant for 6-ary type constructors
  class Typeable6 t where
    typeOf6 :: t a b c d e f -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
  typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
  typeOf5Default = \_ -> rep
   where
     rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
  typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
  typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b c d e f -> a
     argType = undefined
  #endif
  
  -- | Variant for 7-ary type constructors
  class Typeable7 t where
    typeOf7 :: t a b c d e f g -> TypeRep
  
  #ifdef __GLASGOW_HASKELL__
  -- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
  typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
  typeOf6Default = \_ -> rep
   where
     rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` 
           typeOf  (undefined :: a)
     -- Note [Memoising typeOf]
  #else
  -- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
  typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
  typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
   where
     argType :: t a b c d e f g -> a
     argType = undefined
  #endif
  
  #ifdef __GLASGOW_HASKELL__
  -- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
  -- define the instances for partial applications.
  -- Programmers using non-GHC implementations must do this manually
  -- for each type constructor.
  -- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
  
  -- | One Typeable instance for all Typeable1 instances
  instance (Typeable1 s, Typeable a)
         => Typeable (s a) where
    typeOf = typeOfDefault
  
  -- | One Typeable1 instance for all Typeable2 instances
  instance (Typeable2 s, Typeable a)
         => Typeable1 (s a) where
    typeOf1 = typeOf1Default
  
  -- | One Typeable2 instance for all Typeable3 instances
  instance (Typeable3 s, Typeable a)
         => Typeable2 (s a) where
    typeOf2 = typeOf2Default
  
  -- | One Typeable3 instance for all Typeable4 instances
  instance (Typeable4 s, Typeable a)
         => Typeable3 (s a) where
    typeOf3 = typeOf3Default
  
  -- | One Typeable4 instance for all Typeable5 instances
  instance (Typeable5 s, Typeable a)
         => Typeable4 (s a) where
    typeOf4 = typeOf4Default
  
  -- | One Typeable5 instance for all Typeable6 instances
  instance (Typeable6 s, Typeable a)
         => Typeable5 (s a) where
    typeOf5 = typeOf5Default
  
  -- | One Typeable6 instance for all Typeable7 instances
  instance (Typeable7 s, Typeable a)
         => Typeable6 (s a) where
    typeOf6 = typeOf6Default
  
  #endif /* __GLASGOW_HASKELL__ */
  
  ----------------- Showing TypeReps --------------------
  
  instance Show TypeRep where
    showsPrec p (TypeRep _ tycon tys) =
      case tys of
        [] -> showsPrec p tycon
        [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
        [a,r] | tycon == funTc  -> showParen (p > 8) $
                                   showsPrec 9 a .
                                   showString " -> " .
                                   showsPrec 8 r
        xs | isTupleTyCon tycon -> showTuple xs
           | otherwise         ->
              showParen (p > 9) $
              showsPrec p tycon . 
              showChar ' '      . 
              showArgs tys
  
  showsTypeRep :: TypeRep -> ShowS
  showsTypeRep = shows
  
  instance Show TyCon where
    showsPrec _ t = showString (tyConName t)
  
  isTupleTyCon :: TyCon -> Bool
  isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
  isTupleTyCon _                         = False
  
  -- Some (Show.TypeRep) helpers:
  
  showArgs :: Show a => [a] -> ShowS
  showArgs [] = id
  showArgs [a] = showsPrec 10 a
  showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
  
  showTuple :: [TypeRep] -> ShowS
  showTuple args = showChar '('
                 . (foldr (.) id $ intersperse (showChar ',') 
                                 $ map (showsPrec 10) args)
                 . showChar ')'
  
  #if defined(__GLASGOW_HASKELL__)
  listTc :: TyCon
  listTc = typeRepTyCon (typeOf [()])
  
  funTc :: TyCon
  funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
  #endif
  
  -------------------------------------------------------------
  --
  --      Instances of the Typeable classes for Prelude types
  --
  -------------------------------------------------------------
  
  #include "Typeable.h"
  
  INSTANCE_TYPEABLE0((),unitTc,"()")
  INSTANCE_TYPEABLE1([],listTc,"[]")
  INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
  INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
  #if defined(__GLASGOW_HASKELL__)
  {-
  TODO: Deriving this instance fails with:
  libraries/base/Data/Typeable.hs:589:1:
      Can't make a derived instance of `Typeable2 (->)':
        The last argument of the instance must be a data or newtype application
      In the stand-alone deriving instance for `Typeable2 (->)'
  -}
  instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
  #else
  INSTANCE_TYPEABLE2((->),funTc,"->")
  #endif
  INSTANCE_TYPEABLE1(IO,ioTc,"IO")
  
  #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
  -- Types defined in GHC.MVar
  INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
  #endif
  
  INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
  INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
  
  #ifdef __GLASGOW_HASKELL__
  -- Hugs has these too, but their Typeable<n> instances are defined
  -- elsewhere to keep this module within Haskell 98.
  -- This is important because every invocation of runhugs or ffihugs
  -- uses this module via Data.Dynamic.
  INSTANCE_TYPEABLE2(ST,stTc,"ST")
  INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
  INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
  #endif
  
  #ifndef __NHC__
  INSTANCE_TYPEABLE2((,),pairTc,"(,)")
  INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
  INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
  INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
  INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
  INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
  #endif /* __NHC__ */
  
  INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
  INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
  #ifndef __GLASGOW_HASKELL__
  INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
  #endif
  INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
  INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
  
  -------------------------------------------------------
  --
  -- Generate Typeable instances for standard datatypes
  --
  -------------------------------------------------------
  
  INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
  INSTANCE_TYPEABLE0(Char,charTc,"Char")
  INSTANCE_TYPEABLE0(Float,floatTc,"Float")
  INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
  INSTANCE_TYPEABLE0(Int,intTc,"Int")
  #ifndef __NHC__
  INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
  #endif
  INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
  INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
  #ifndef __GLASGOW_HASKELL__
  INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
  #endif
  
  INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
  INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
  INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
  INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
  
  INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
  INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
  INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
  INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
  
  INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
  INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
  
  #ifdef __GLASGOW_HASKELL__
  {-
  TODO: This can't be derived currently:
  libraries/base/Data/Typeable.hs:674:1:
      Can't make a derived instance of `Typeable RealWorld':
        The last argument of the instance must be a data or newtype application
      In the stand-alone deriving instance for `Typeable RealWorld'
  -}
  realWorldTc :: TyCon; \
  realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
  instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
  
  #endif
  