path: root/libraries/base/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 construcotr 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) []