content: {-# LINE 1 "Data.Typeable.Internal.hs" #-}
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE TypeApplications #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- 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.
  --
  -----------------------------------------------------------------------------
  
  module Data.Typeable.Internal (
      Proxy (..),
      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,
  
      -- * TypeRep
      TypeRep(..), KindRep,
      typeRep,
      mkTyConApp,
      mkPolyTyConApp,
      mkAppTy,
      typeRepTyCon,
      Typeable(..),
      mkFunTy,
      splitTyConApp,
      splitPolyTyConApp,
      funResultTy,
      typeRepArgs,
      typeRepFingerprint,
      rnfTypeRep,
      showsTypeRep,
      typeRepKinds,
      typeSymbolTypeRep, typeNatTypeRep
    ) where
  
  import GHC.Base
  import GHC.Types (TYPE)
  import GHC.Word
  import GHC.Show
  import Data.Proxy
  import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' )
  
  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.
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  {- *********************************************************************
  *                                                                      *
                  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.
  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
  
  -- Compare keys for equality
  instance Eq TypeRep where
    TypeRep x _ _ _ == TypeRep y _ _ _ = x == y
  
  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
  mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
  {-# INLINE mkPolyTyConApp #-}
  mkPolyTyConApp tc kinds types
    = TypeRep (fingerprintFingerprints sub_fps) tc kinds types
    where
      !kt_fps = typeRepFingerprints kinds types
      sub_fps = tyConFingerprint tc : kt_fps
  
  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
  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]
  
  -- | Splits a type constructor application.
  -- Note that if the type constructor is polymorphic, this will
  -- not return the kinds that were used.
  -- See 'splitPolyTyConApp' if you need all parts.
  splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
  splitTyConApp (TypeRep _ tc _ trs) = (tc,trs)
  
  -- | Split a type constructor application
  splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep])
  splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,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 == tcFun && t1 == trArg -> Just t2
        _ -> Nothing
  
  tyConOf :: Typeable a => Proxy a -> TyCon
  tyConOf = typeRepTyCon . typeRep
  
  tcFun :: TyCon
  tcFun = tyConOf (Proxy :: Proxy (Int -> Int))
  
  -- | 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
     -- the new one won't give the same answer, but of course we want to
     -- ensure that a TypeRep of the same shape has the same fingerprint!
     -- See Trac #5962
  
  ----------------- 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 _ _ _ tys) = tys
  
  -- | Observe the argument kinds of a type representation
  typeRepKinds :: TypeRep -> [KindRep]
  typeRepKinds (TypeRep _ _ ks _) = ks
  
  
  {- *********************************************************************
  *                                                                      *
                  The Typeable class
  *                                                                      *
  ********************************************************************* -}
  
  -------------------------------------------------------------
  --
  --      The Typeable class and friends
  --
  -------------------------------------------------------------
  
  -- | The class 'Typeable' allows a concrete representation of a type to
  -- be calculated.
  class Typeable a where
    typeRep# :: Proxy# a -> TypeRep
  
  -- | Takes a value of type @a@ and returns a concrete representation
  -- of that type.
  --
  -- @since 4.7.0.0
  typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
  typeRep _ = typeRep# (proxy# :: Proxy# a)
  {-# INLINE typeRep #-}
  
  -- Keeping backwards-compatibility
  typeOf :: forall a. Typeable a => a -> TypeRep
  typeOf _ = typeRep (Proxy :: Proxy a)
  
  typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
  typeOf1 _ = typeRep (Proxy :: Proxy t)
  
  typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
  typeOf2 _ = typeRep (Proxy :: Proxy t)
  
  typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
          => t a b c -> TypeRep
  typeOf3 _ = typeRep (Proxy :: Proxy t)
  
  typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
          => t a b c d -> TypeRep
  typeOf4 _ = typeRep (Proxy :: Proxy t)
  
  typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
          => t a b c d e -> TypeRep
  typeOf5 _ = typeRep (Proxy :: Proxy t)
  
  typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
                  Typeable t => t a b c d e f -> TypeRep
  typeOf6 _ = typeRep (Proxy :: Proxy t)
  
  typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
                  (g :: *). Typeable t => t a b c d e f g -> TypeRep
  typeOf7 _ = typeRep (Proxy :: Proxy t)
  
  type Typeable1 (a :: * -> *)                               = Typeable a
  type Typeable2 (a :: * -> * -> *)                          = Typeable a
  type Typeable3 (a :: * -> * -> * -> *)                     = Typeable a
  type Typeable4 (a :: * -> * -> * -> * -> *)                = Typeable a
  type Typeable5 (a :: * -> * -> * -> * -> * -> *)           = Typeable a
  type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *)      = Typeable a
  type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
  
  {-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  {-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8
  
  
  ----------------- Showing TypeReps --------------------
  
  instance Show TypeRep where
    showsPrec p (TypeRep _ tycon kinds tys) =
      case tys of
        [] -> showsPrec p tycon
        [x]
          | tycon == tcList -> showChar '[' . shows x . showChar ']'
          where
            tcList = tyConOf @[] Proxy
        [TypeRep _ ptrRepCon _ []]
          | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted
            -> showChar '*'
          | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted
            -> showChar '#'
          where
            tcTYPE            = tyConOf @TYPE            Proxy
            tc'PtrRepLifted   = tyConOf @'PtrRepLifted   Proxy
            tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy
        [a,r] | tycon == tcFun  -> showParen (p > 8) $
                                   showsPrec 9 a .
                                   showString " -> " .
                                   showsPrec 8 r
        xs | isTupleTyCon tycon -> showTuple xs
           | otherwise         ->
              showParen (p > 9) $
              showsPrec p tycon .
              showChar ' '      .
              showArgs (showChar ' ') (kinds ++ tys)
  
  showsTypeRep :: TypeRep -> ShowS
  showsTypeRep = shows
  
  -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
  --
  -- @since 4.8.0.0
  rnfTypeRep :: TypeRep -> ()
  rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
    where
      go [] = ()
      go (x:xs) = rnfTypeRep x `seq` go xs
  
  -- Some (Show.TypeRep) helpers:
  
  showArgs :: Show a => ShowS -> [a] -> ShowS
  showArgs _   []     = id
  showArgs _   [a]    = showsPrec 10 a
  showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
  
  showTuple :: [TypeRep] -> ShowS
  showTuple args = showChar '('
                 . showArgs (showChar ',') args
                 . showChar ')'
  
  {- *********************************************************
  *                                                          *
  *       TyCon/TypeRep definitions for type literals        *
  *              (Symbol and Nat)                            *
  *                                                          *
  ********************************************************* -}
  
  
  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))
  
  -- | Used to make `'Typeable' instance for things of kind Symbol
  typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
  typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
  
  -- | An internal function, to make representations for type literals.
  typeLitTypeRep :: String -> TypeRep
  typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) []
  