base-4.9.0.0: 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.
#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.
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) []