{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE LinearTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.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 GHC.Internal.Data.Typeable.Internal (
    -- * Typeable and kind polymorphism
    --
    -- #kind_instantiation

    -- * Miscellaneous
    Fingerprint(..),

    -- * Typeable class
    Typeable(..),
    withTypeable,

    -- * Module
    Module,  -- Abstract
    moduleName, modulePackage, rnfModule,

    -- * TyCon
    TyCon,   -- Abstract
    tyConPackage, tyConModule, tyConName, tyConKindArgs, tyConKindRep,
    tyConFingerprint,
    KindRep(.., KindRepTypeLit), TypeLitSort(..),
    rnfTyCon,

    -- * TypeRep
    TypeRep,
    pattern TypeRep,
    pattern App, pattern Con, pattern Con', pattern Fun,
    typeRep,
    typeOf,
    typeRepTyCon,
    typeRepFingerprint,
    rnfTypeRep,
    eqTypeRep,
    decTypeRep,
    typeRepKind,
    splitApps,

    -- * SomeTypeRep
    SomeTypeRep(..),
    someTypeRep,
    someTypeRepTyCon,
    someTypeRepFingerprint,
    rnfSomeTypeRep,

    -- * Construction
    -- | These are for internal use only
    mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,
    mkTyCon, mkTyCon#,
    typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep,

    -- * For internal use
    trLiftedRep
  ) where

import GHC.Internal.Base
import qualified GHC.Internal.Arr as A
import GHC.Internal.Data.Either (Either (..))
import GHC.Internal.Data.Type.Equality
import GHC.Internal.List ( splitAt, foldl', elem, replicate, length )
import GHC.Internal.Unicode (isDigit)
import GHC.Internal.Num ((-), (+), (*))
import GHC.Internal.Word
import GHC.Internal.Show
import GHC.Internal.TypeLits ( KnownChar, charVal', KnownSymbol, symbolVal'
                    , TypeError, ErrorMessage(..) )
import GHC.Internal.TypeNats ( KnownNat, Nat, natVal' )
import GHC.Internal.Unsafe.Coerce ( unsafeCoerce )

import GHC.Internal.Fingerprint.Type
import {-# SOURCE #-} GHC.Internal.Fingerprint
   -- loop: GHC.Internal.Fingerprint -> GHC.Internal.Foreign.Ptr -> GHC.Internal.Data.Typeable
   -- Better to break the loop here, because we want non-SOURCE imports
   -- of GHC.Internal.Data.Typeable as much as possible so we can optimise the derived
   -- instances.
-- import {-# SOURCE #-} GHC.Internal.Debug.Trace (trace)

#include "MachDeps.h"

{- *********************************************************************
*                                                                      *
                The TyCon type
*                                                                      *
********************************************************************* -}

modulePackage :: Module -> String
modulePackage :: Module -> String
modulePackage (Module TrName
p TrName
_) = TrName -> String
trNameString TrName
p

moduleName :: Module -> String
moduleName :: Module -> String
moduleName (Module TrName
_ TrName
m) = TrName -> String
trNameString TrName
m

tyConPackage :: TyCon -> String
tyConPackage :: TyCon -> String
tyConPackage (TyCon Word64#
_ Word64#
_ Module
m TrName
_ Int#
_ KindRep
_) = Module -> String
modulePackage Module
m

tyConModule :: TyCon -> String
tyConModule :: TyCon -> String
tyConModule (TyCon Word64#
_ Word64#
_ Module
m TrName
_ Int#
_ KindRep
_) = Module -> String
moduleName Module
m

tyConName :: TyCon -> String
tyConName :: TyCon -> String
tyConName (TyCon Word64#
_ Word64#
_ Module
_ TrName
n Int#
_ KindRep
_) = TrName -> String
trNameString TrName
n

trNameString :: TrName -> String
trNameString :: TrName -> String
trNameString (TrNameS Addr#
s) = Addr# -> String
unpackCStringUtf8# Addr#
s
trNameString (TrNameD String
s) = String
s

tyConFingerprint :: TyCon -> Fingerprint
tyConFingerprint :: TyCon -> Fingerprint
tyConFingerprint (TyCon Word64#
hi Word64#
lo Module
_ TrName
_ Int#
_ KindRep
_)
  = Word64 -> Word64 -> Fingerprint
Fingerprint (Word64# -> Word64
W64# Word64#
hi) (Word64# -> Word64
W64# Word64#
lo)

tyConKindArgs :: TyCon -> Int
tyConKindArgs :: TyCon -> Int
tyConKindArgs (TyCon Word64#
_ Word64#
_ Module
_ TrName
_ Int#
n KindRep
_) = Int# -> Int
I# Int#
n

tyConKindRep :: TyCon -> KindRep
tyConKindRep :: TyCon -> KindRep
tyConKindRep (TyCon Word64#
_ Word64#
_ Module
_ TrName
_ Int#
_ KindRep
k) = KindRep
k

-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
--
-- @since base-4.8.0.0
rnfModule :: Module -> ()
rnfModule :: Module -> ()
rnfModule (Module TrName
p TrName
m) = TrName -> ()
rnfTrName TrName
p () -> () -> ()
forall a b. a -> b -> b
`seq` TrName -> ()
rnfTrName TrName
m

rnfTrName :: TrName -> ()
rnfTrName :: TrName -> ()
rnfTrName (TrNameS Addr#
_) = ()
rnfTrName (TrNameD String
n) = String -> ()
rnfString String
n

rnfKindRep :: KindRep -> ()
rnfKindRep :: KindRep -> ()
rnfKindRep (KindRepTyConApp TyCon
tc [KindRep]
args) = TyCon -> ()
rnfTyCon TyCon
tc () -> () -> ()
forall a b. a -> b -> b
`seq` (KindRep -> ()) -> [KindRep] -> ()
forall a. (a -> ()) -> [a] -> ()
rnfList KindRep -> ()
rnfKindRep [KindRep]
args
rnfKindRep (KindRepVar Int
_)   = ()
rnfKindRep (KindRepApp KindRep
a KindRep
b) = KindRep -> ()
rnfKindRep KindRep
a () -> () -> ()
forall a b. a -> b -> b
`seq` KindRep -> ()
rnfKindRep KindRep
b
rnfKindRep (KindRepFun KindRep
a KindRep
b) = KindRep -> ()
rnfKindRep KindRep
a () -> () -> ()
forall a b. a -> b -> b
`seq` KindRep -> ()
rnfKindRep KindRep
b
rnfKindRep (KindRepTYPE RuntimeRep
rr) = RuntimeRep -> ()
rnfRuntimeRep RuntimeRep
rr
rnfKindRep (KindRepTypeLitS TypeLitSort
_ Addr#
_) = ()
rnfKindRep (KindRepTypeLitD TypeLitSort
_ String
t) = String -> ()
rnfString String
t

rnfRuntimeRep :: RuntimeRep -> ()
rnfRuntimeRep :: RuntimeRep -> ()
rnfRuntimeRep (VecRep !VecCount
_ !VecElem
_) = ()
rnfRuntimeRep !RuntimeRep
_             = ()

rnfList :: (a -> ()) -> [a] -> ()
rnfList :: forall a. (a -> ()) -> [a] -> ()
rnfList a -> ()
_     []     = ()
rnfList a -> ()
force (a
x:[a]
xs) = a -> ()
force a
x () -> () -> ()
forall a b. a -> b -> b
`seq` (a -> ()) -> [a] -> ()
forall a. (a -> ()) -> [a] -> ()
rnfList a -> ()
force [a]
xs

rnfString :: [Char] -> ()
rnfString :: String -> ()
rnfString = (Char -> ()) -> String -> ()
forall a. (a -> ()) -> [a] -> ()
rnfList (Char -> () -> ()
forall a b. a -> b -> b
`seq` ())

rnfTyCon :: TyCon -> ()
rnfTyCon :: TyCon -> ()
rnfTyCon (TyCon Word64#
_ Word64#
_ Module
m TrName
n Int#
_ KindRep
k) = Module -> ()
rnfModule Module
m () -> () -> ()
forall a b. a -> b -> b
`seq` TrName -> ()
rnfTrName TrName
n () -> () -> ()
forall a b. a -> b -> b
`seq` KindRep -> ()
rnfKindRep KindRep
k


{- *********************************************************************
*                                                                      *
                The TypeRep type
*                                                                      *
********************************************************************* -}

-- | TypeRep is a concrete representation of a (monomorphic) type.
-- 'TypeRep' supports reasonably efficient equality.
-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable
type TypeRep :: k -> Type
data TypeRep a where
    -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2
    TrType :: TypeRep Type
    TrTyCon :: { -- See Note [TypeRep fingerprints]
                 forall k (a :: k). TypeRep a -> Fingerprint
trTyConFingerprint :: {-# UNPACK #-} !Fingerprint

                 -- The TypeRep represents the application of trTyCon
                 -- to the kind arguments trKindVars. So for
                 -- 'Just :: Bool -> Maybe Bool, the trTyCon will be
                 -- 'Just and the trKindVars will be [Bool].
               , forall k (a :: k). TypeRep a -> TyCon
trTyCon :: !TyCon
               , forall k (a :: k). TypeRep a -> [SomeTypeRep]
trKindVars :: [SomeTypeRep]
               , forall k (a :: k). TypeRep a -> TypeRep k
trTyConKind :: !(TypeRep k) }  -- See Note [Kind caching]
            -> TypeRep (a :: k)

    -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)
    -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b@.
    TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
               { -- See Note [TypeRep fingerprints]
                 forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> Fingerprint
trAppFingerprint :: {-# UNPACK #-} !Fingerprint

                 -- The TypeRep represents the application of trAppFun
                 -- to trAppArg. For Maybe Int, the trAppFun will be Maybe
                 -- and the trAppArg will be Int.
               , forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun :: !(TypeRep (a :: k1 -> k2))
               , forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg :: !(TypeRep (b :: k1))
               , forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep k2
trAppKind :: !(TypeRep k2) }   -- See Note [Kind caching]
            -> TypeRep (a b)

    -- | @TrFun fpr m a b@ represents a function type @a % m -> b@. We use this for
    -- the sake of efficiency as functions are quite ubiquitous.
    -- A TrFun can represent `t1 -> t2` or `t1 -= t2`; but not  (a => b) or (a ==> b).
    -- See Note [No Typeable for polytypes or qualified types] in GHC.Tc.Instance.Class
    -- and Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim
    -- We do not represent the function TyCon (i.e. (->) vs (-=>)) explicitly;
    -- instead, the TyCon is implicit in the kinds of the arguments.
    TrFun   :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (a :: TYPE r1) (b :: TYPE r2).
               { -- See Note [TypeRep fingerprints]
                 forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> Fingerprint
trFunFingerprint :: {-# UNPACK #-} !Fingerprint

                 -- The TypeRep represents a function from trFunArg to
                 -- trFunRes.
               , forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep m
trFunMul :: !(TypeRep m)
               , forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep LiftedRep
trFunArg :: !(TypeRep a)
               , forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep b
trFunRes :: !(TypeRep b) }
            -> TypeRep (FUN m a b)

-- | A 'TypeableInstance' wraps up a 'Typeable' instance for explicit
-- handling. For internal use: for defining 'TypeRep' pattern.
type TypeableInstance :: forall k. k -> Type
data TypeableInstance a where
 TypeableInstance :: Typeable a => TypeableInstance a

-- | Get a reified 'Typeable' instance from an explicit 'TypeRep'.
--
-- For internal use: for defining 'TypeRep' pattern.
typeableInstance :: forall {k :: Type} (a :: k). TypeRep a -> TypeableInstance a
typeableInstance :: forall {k} (a :: k). TypeRep a -> TypeableInstance a
typeableInstance TypeRep a
rep = TypeRep a
-> (Typeable a => TypeableInstance a) -> TypeableInstance a
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
withTypeable TypeRep a
rep TypeableInstance a
Typeable a => TypeableInstance a
forall {k} (a :: k). Typeable a => TypeableInstance a
TypeableInstance

-- | A explicitly bidirectional pattern synonym to construct a
-- concrete representation of a type.
--
-- As an __expression__: Constructs a singleton @TypeRep a@ given a
-- implicit 'Typeable a' constraint:
--
-- @
-- TypeRep @a :: Typeable a => TypeRep a
-- @
--
-- As a __pattern__: Matches on an explicit @TypeRep a@ witness bringing
-- an implicit @Typeable a@ constraint into scope.
--
-- @
-- f :: TypeRep a -> ..
-- f TypeRep = {- Typeable a in scope -}
-- @
--
-- @since base-4.17.0.0
pattern TypeRep :: forall {k :: Type} (a :: k). () => Typeable @k a => TypeRep @k a
pattern $mTypeRep :: forall {r} {k} {a :: k}.
TypeRep a -> (Typeable a => r) -> ((# #) -> r) -> r
$bTypeRep :: forall {k} (a :: k). Typeable a => TypeRep a
TypeRep <- (typeableInstance -> TypeableInstance)
  where TypeRep = TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep
{-# COMPLETE TypeRep #-}

{- Note [TypeRep fingerprints]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
We store a Fingerprint of each TypeRep in its constructor. This allows
us to test whether two TypeReps are equal in constant time, rather than
having to walk their full structures.
-}

{- Note [Kind caching]
   ~~~~~~~~~~~~~~~~~~~
We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.
This is necessary to ensure that typeRepKind (which is used, at least, in
deserialization and dynApply) is cheap. There are two reasons for this:

1. Calculating the kind of a nest of type applications, such as

  F X Y Z W   (App (App (App (App F X) Y) Z) W)

is linear in the depth, which is already a bit pricy. In deserialization,
we build up such a nest from the inside out, so without caching, that ends
up taking quadratic time, and calculating the KindRep of the constructor,
F, a linear number of times. See #14254.

2. Calculating the kind of a type constructor, in instantiateTypeRep,
requires building (allocating) a TypeRep for the kind "from scratch".
This can get pricy. When combined with point (1), we can end up with
a large amount of extra allocation deserializing very deep nests.
See #14337.

It is quite possible to speed up deserialization by structuring that process
very carefully. Unfortunately, that doesn't help dynApply or anything else
that may use typeRepKind. Since caching the kind isn't terribly expensive, it
seems better to just do that and solve all the potential problems at once.

There are two things we need to be careful about when caching kinds.

Wrinkle 1:

We want to do it eagerly. Suppose we have

  tf :: TypeRep (f :: j -> k)
  ta :: TypeRep (a :: j)

Then the cached kind of App tf ta should be eagerly evaluated to k, rather
than being stored as a thunk that will strip the (j ->) off of j -> k if
and when it is forced.

Wrinkle 2:

We need to be able to represent TypeRep Type. This is a bit tricky because
typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the
typerep of the kind of Type, we will have a loop. One simple way to do this
is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.

But we *do not* want TypeReps to have cyclical structure! Most importantly,
a cyclical structure cannot be stored in a compact region. Secondarily,
using :force in GHCi on a cyclical structure will lead to non-termination.

To avoid this trouble, we use a separate constructor for TypeRep Type.
mkTrApp is responsible for recognizing that TYPE is being applied to
'LiftedRep and produce trType; other functions must recognize that TrType
represents an application.
-}

-- Compare keys for equality

-- | @since base-2.01
instance Eq (TypeRep a) where
  TypeRep a
_ == :: TypeRep a -> TypeRep a -> Bool
== TypeRep a
_  = Bool
True
  {-# INLINABLE (==) #-}

instance TestEquality TypeRep where
  TypeRep a
a testEquality :: forall (a :: k) (b :: k). TypeRep a -> TypeRep b -> Maybe (a :~: b)
`testEquality` TypeRep b
b
    | Just a :~~: b
HRefl <- TypeRep a -> TypeRep b -> Maybe (a :~~: b)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
a TypeRep b
b
    = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    | Bool
otherwise
    = Maybe (a :~: b)
forall a. Maybe a
Nothing
  {-# INLINEABLE testEquality #-}

-- | @since base-4.4.0.0
instance Ord (TypeRep a) where
  compare :: TypeRep a -> TypeRep a -> Ordering
compare TypeRep a
_ TypeRep a
_ = Ordering
EQ
  {-# INLINABLE compare #-}

-- | A non-indexed type representation.
data SomeTypeRep where
    SomeTypeRep :: forall k (a :: k). !(TypeRep a) %1 -> SomeTypeRep

instance Eq SomeTypeRep where
  SomeTypeRep TypeRep a
a == :: SomeTypeRep -> SomeTypeRep -> Bool
== SomeTypeRep TypeRep a
b =
      case TypeRep a
a TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
b of
          Just a :~~: a
_  -> Bool
True
          Maybe (a :~~: a)
Nothing -> Bool
False

instance Ord SomeTypeRep where
  SomeTypeRep TypeRep a
a compare :: SomeTypeRep -> SomeTypeRep -> Ordering
`compare` SomeTypeRep TypeRep a
b =
    TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
a Fingerprint -> Fingerprint -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
b

-- | The function type constructor.
--
-- For instance,
--
-- @
-- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char)
-- @
--
pattern Fun :: forall k (fun :: k). ()
            => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (arg :: TYPE r1) (res :: TYPE r2).
               (k ~ Type, fun ~~ (arg -> res))
            => TypeRep arg
            -> TypeRep res
            -> TypeRep fun
pattern $mFun :: forall {r} {k} {fun :: k}.
TypeRep fun
-> (forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} {arg :: TYPE r1}
           {res :: TYPE r2}.
    (k ~ *, fun ~~ (arg -> res)) =>
    TypeRep arg -> TypeRep res -> r)
-> ((# #) -> r)
-> r
$bFun :: forall k (fun :: k) arg res.
(k ~ *, fun ~~ (arg -> res)) =>
TypeRep arg -> TypeRep res -> TypeRep fun
Fun arg res <- TrFun {trFunArg = arg, trFunRes = res, trFunMul = (eqTypeRep trMany -> Just HRefl)}
  where Fun TypeRep arg
arg TypeRep res
res = TypeRep 'Many -> TypeRep arg -> TypeRep res -> TypeRep (arg -> res)
forall (m :: Multiplicity) a b.
TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a %m -> b)
mkTrFun TypeRep 'Many
trMany TypeRep arg
arg TypeRep res
res

-- | Observe the 'Fingerprint' of a type representation
--
-- @since base-4.8.0.0
typeRepFingerprint :: TypeRep a -> Fingerprint
typeRepFingerprint :: forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
TrType = Fingerprint
fpTYPELiftedRep
typeRepFingerprint (TrTyCon {trTyConFingerprint :: forall k (a :: k). TypeRep a -> Fingerprint
trTyConFingerprint = Fingerprint
fpr}) = Fingerprint
fpr
typeRepFingerprint (TrApp {trAppFingerprint :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> Fingerprint
trAppFingerprint = Fingerprint
fpr}) = Fingerprint
fpr
typeRepFingerprint (TrFun {trFunFingerprint :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> Fingerprint
trFunFingerprint = Fingerprint
fpr}) = Fingerprint
fpr

-- For compiler use
mkTrType :: TypeRep Type
mkTrType :: TypeRep (*)
mkTrType = TypeRep (*)
TrType

-- | Construct a representation for a type constructor
-- applied at a monomorphic kind.
--
-- Note that this is unsafe as it allows you to construct
-- ill-kinded types.
mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon TyCon
tc [SomeTypeRep]
kind_vars = TrTyCon
    { trTyConFingerprint :: Fingerprint
trTyConFingerprint = Fingerprint
fpr
    , trTyCon :: TyCon
trTyCon = TyCon
tc
    , trKindVars :: [SomeTypeRep]
trKindVars = [SomeTypeRep]
kind_vars
    , trTyConKind :: TypeRep k
trTyConKind = TypeRep k
kind }
  where
    fpr_tc :: Fingerprint
fpr_tc  = TyCon -> Fingerprint
tyConFingerprint TyCon
tc
    fpr_kvs :: [Fingerprint]
fpr_kvs = (SomeTypeRep -> Fingerprint) -> [SomeTypeRep] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map SomeTypeRep -> Fingerprint
someTypeRepFingerprint [SomeTypeRep]
kind_vars
    fpr :: Fingerprint
fpr     = [Fingerprint] -> Fingerprint
fingerprintFingerprints (Fingerprint
fpr_tcFingerprint -> [Fingerprint] -> [Fingerprint]
forall a. a -> [a] -> [a]
:[Fingerprint]
fpr_kvs)
    kind :: TypeRep k
kind    = SomeTypeRep -> TypeRep k
forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep -> TypeRep k) -> SomeTypeRep -> TypeRep k
forall a b. (a -> b) -> a -> b
$ TyCon -> [SomeTypeRep] -> SomeTypeRep
tyConKind TyCon
tc [SomeTypeRep]
kind_vars

-- The fingerprint of Type. We don't store this in the TrType
-- constructor, so we need to build it here.
fpTYPELiftedRep :: Fingerprint
fpTYPELiftedRep :: Fingerprint
fpTYPELiftedRep = [Fingerprint] -> Fingerprint
fingerprintFingerprints
      [ TyCon -> Fingerprint
tyConFingerprint TyCon
tyConTYPE
      , [Fingerprint] -> Fingerprint
fingerprintFingerprints
        [ TyCon -> Fingerprint
tyConFingerprint TyCon
tyCon'BoxedRep
        , TyCon -> Fingerprint
tyConFingerprint TyCon
tyCon'Lifted
        ]
      ]
-- There is absolutely nothing to gain and everything to lose
-- by inlining the worker. The wrapper should inline anyway.
{-# NOINLINE fpTYPELiftedRep #-}

trTYPE :: TypeRep TYPE
trTYPE :: TypeRep TYPE
trTYPE = TypeRep TYPE
forall {k} (a :: k). Typeable a => TypeRep a
typeRep

trLiftedRep :: TypeRep ('BoxedRep 'Lifted)
trLiftedRep :: TypeRep LiftedRep
trLiftedRep = TypeRep LiftedRep
forall {k} (a :: k). Typeable a => TypeRep a
typeRep

trMany :: TypeRep 'Many
trMany :: TypeRep 'Many
trMany = TypeRep 'Many
forall {k} (a :: k). Typeable a => TypeRep a
typeRep

-- | Construct a representation for a type application that is
-- NOT a saturated arrow type. This is not checked!

-- Note that this is known-key to the compiler, which uses it in desugar
-- 'Typeable' evidence.
mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
           TypeRep (a :: k1 -> k2)
        -> TypeRep (b :: k1)
        -> TypeRep (a b)
mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep a
a TypeRep b
b -- See Note [Kind caching], Wrinkle 2
  | Just a :~~: TYPE
HRefl <- TypeRep a
a TypeRep a -> TypeRep TYPE -> Maybe (a :~~: TYPE)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep TYPE
trTYPE
  , Just b :~~: LiftedRep
HRefl <- TypeRep b
b TypeRep b -> TypeRep LiftedRep -> Maybe (b :~~: LiftedRep)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep LiftedRep
trLiftedRep
  = TypeRep (a b)
TypeRep (*)
TrType

  | TrFun {trFunRes :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep b
trFunRes = TypeRep b
res_kind} <- TypeRep a -> TypeRep (k1 -> k2)
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
a
  = TrApp
    { trAppFingerprint :: Fingerprint
trAppFingerprint = Fingerprint
fpr
    , trAppFun :: TypeRep a
trAppFun = TypeRep a
a
    , trAppArg :: TypeRep b
trAppArg = TypeRep b
b
    , trAppKind :: TypeRep k2
trAppKind = TypeRep b
TypeRep k2
res_kind }

  | Bool
otherwise = String -> TypeRep (a b)
forall a. HasCallStack => String -> a
error (String
"Ill-kinded type application: "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep (k1 -> k2) -> String
forall a. Show a => a -> String
show (TypeRep a -> TypeRep (k1 -> k2)
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
a))
  where
    fpr_a :: Fingerprint
fpr_a = TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
a
    fpr_b :: Fingerprint
fpr_b = TypeRep b -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep b
b
    fpr :: Fingerprint
fpr   = [Fingerprint] -> Fingerprint
fingerprintFingerprints [Fingerprint
fpr_a, Fingerprint
fpr_b]

-- | Construct a representation for a type application that
-- may be a saturated arrow type. This is renamed to mkTrApp in
-- Type.Reflection.Unsafe
mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
                  TypeRep (a :: k1 -> k2)
               -> TypeRep (b :: k1)
               -> TypeRep (a b)
mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrAppChecked rep :: TypeRep a
rep@(TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun = TypeRep a
p, trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg = x :: TypeRep b
x@TypeRep b
TypeRep :: TypeRep x})
               (TypeRep b
y :: TypeRep y)
  | TrTyCon {trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon=TyCon
con} <- TypeRep a
p
  , TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon  -- cheap check first
  , Just (IsTYPE TypeRep r
TypeRep) <- TypeRep k1 -> Maybe (IsTYPE k1)
forall a. TypeRep a -> Maybe (IsTYPE a)
isTYPE (TypeRep b -> TypeRep k1
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep b
x)
  , Just (IsTYPE (TypeRep r
TypeRep :: TypeRep ry)) <- TypeRep k1 -> Maybe (IsTYPE k1)
forall a. TypeRep a -> Maybe (IsTYPE a)
isTYPE (TypeRep b -> TypeRep k1
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep b
y)
  , Just (->) b :~~: a
HRefl <- forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: TYPE r -> *). Typeable a => TypeRep a
typeRep @((->) x :: TYPE ry -> Type) TypeRep ((->) b) -> TypeRep a -> Maybe ((->) b :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
rep
  = TypeRep 'Many -> TypeRep b -> TypeRep b -> TypeRep (b -> b)
forall (m :: Multiplicity) a b.
TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a %m -> b)
mkTrFun TypeRep 'Many
trMany TypeRep b
TypeRep b
x TypeRep b
TypeRep b
y
mkTrAppChecked TypeRep a
a TypeRep b
b = TypeRep a -> TypeRep b -> TypeRep (a b)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep a
a TypeRep b
b

-- | A type application.
--
-- For instance,
--
-- @
-- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int)
-- @
--
-- Note that this will also match a function type,
--
-- @
-- typeRep \@(Int# -> Char)
--   ===
-- App (App arrow (typeRep \@Int#)) (typeRep \@Char)
-- @
--
-- where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@.
--
pattern App :: forall k2 (t :: k2). ()
            => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
            => TypeRep a -> TypeRep b -> TypeRep t
pattern $mApp :: forall {r} {k2} {t :: k2}.
TypeRep t
-> (forall {k1} {a :: k1 -> k2} {b :: k1}.
    (t ~ a b) =>
    TypeRep a -> TypeRep b -> r)
-> ((# #) -> r)
-> r
$bApp :: forall k2 (t :: k2) k1 (a :: k1 -> k2) (b :: k1).
(t ~ a b) =>
TypeRep a -> TypeRep b -> TypeRep t
App f x <- (splitApp -> IsApp f x)
  where App TypeRep a
f TypeRep b
x = TypeRep a -> TypeRep b -> TypeRep (a b)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrAppChecked TypeRep a
f TypeRep b
x

data AppOrCon (a :: k) where
    IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
          => TypeRep f %1 -> TypeRep x %1 -> AppOrCon (f x)
    -- See Note [Con evidence]
    IsCon :: NotApplication a => TyCon %1 -> [SomeTypeRep] %1 -> AppOrCon a

type family NotApplication (x :: k) :: Constraint where
  NotApplication (f a)
    = TypeError
      (     'Text "Cannot match this TypeRep with Con or Con': it is an application:"
      ':$$: 'Text "  " ':<>: 'ShowType (f a)
      )
  NotApplication _
    = ()

splitApp :: forall k (a :: k). ()
         => TypeRep a
         -> AppOrCon a
splitApp :: forall k (a :: k). TypeRep a -> AppOrCon a
splitApp TypeRep a
TrType = TypeRep TYPE -> TypeRep LiftedRep -> AppOrCon (*)
forall k m (a :: m -> k) (x :: m).
TypeRep a -> TypeRep x -> AppOrCon (a x)
IsApp TypeRep TYPE
TypeRep TYPE
trTYPE TypeRep LiftedRep
trLiftedRep
splitApp (TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun = TypeRep a
f, trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg = TypeRep b
x}) = TypeRep a -> TypeRep b -> AppOrCon (a b)
forall k m (a :: m -> k) (x :: m).
TypeRep a -> TypeRep x -> AppOrCon (a x)
IsApp TypeRep a
f TypeRep b
x
splitApp rep :: TypeRep a
rep@(TrFun {trFunArg :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep LiftedRep
trFunArg=TypeRep a
a, trFunRes :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep b
trFunRes=TypeRep b
b}) = TypeRep (FUN m a) -> TypeRep b -> AppOrCon (a %m -> b)
forall k m (a :: m -> k) (x :: m).
TypeRep a -> TypeRep x -> AppOrCon (a x)
IsApp (TypeRep (FUN m) -> TypeRep a -> TypeRep (FUN m a)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep (FUN m)
TypeRep (FUN m)
arr TypeRep a
a) TypeRep b
b
  where arr :: TypeRep (FUN m)
arr = TypeRep (a %m -> b) -> TypeRep (FUN m)
forall (m :: Multiplicity) a b.
TypeRep (a %m -> b) -> TypeRep (FUN m)
bareArrow TypeRep a
TypeRep (a %m -> b)
rep
splitApp (TrTyCon{trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon = TyCon
con, trKindVars :: forall k (a :: k). TypeRep a -> [SomeTypeRep]
trKindVars = [SomeTypeRep]
kinds})
  = case (Any :~: Any) -> NotApplication a :~: (() :: Constraint)
forall a b. a -> b
unsafeCoerce Any :~: Any
forall {k} (a :: k). a :~: a
Refl :: NotApplication a :~: (() :: Constraint) of
      NotApplication a :~: (() :: Constraint)
Refl -> TyCon -> [SomeTypeRep] -> AppOrCon a
forall {k} (a :: k).
NotApplication a =>
TyCon -> [SomeTypeRep] -> AppOrCon a
IsCon TyCon
con [SomeTypeRep]
kinds

-- | Use a 'TypeRep' as 'Typeable' evidence.
--
-- The 'TypeRep' pattern synonym brings a 'Typeable' constraint into
-- scope and can be used in place of 'withTypeable'.
--
-- @
-- f :: TypeRep a -> ..
-- f rep = withTypeable {- Typeable a in scope -}
--
-- f :: TypeRep a -> ..
-- f TypeRep = {- Typeable a in scope -}
-- @
withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()
             => TypeRep a -> (Typeable a => r) -> r
withTypeable :: forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
withTypeable TypeRep a
rep Typeable a => r
k = forall (cls :: Constraint) meth r.
WithDict cls meth =>
meth -> (cls => r) -> r
withDict @(Typeable a) TypeRep a
rep r
Typeable a => r
k

-- | Pattern match on a type constructor
pattern Con :: forall k (a :: k). ()
            => NotApplication a -- See Note [Con evidence]
            => TyCon -> TypeRep a
pattern $mCon :: forall {r} {k} {a :: k}.
TypeRep a -> (NotApplication a => TyCon -> r) -> ((# #) -> r) -> r
Con con <- (splitApp -> IsCon con _)

-- | Pattern match on a type constructor including its instantiated kind
-- variables.
--
-- For instance,
--
-- @
-- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int)
-- @
--
-- will bring into scope,
--
-- @
-- proxyTyCon :: TyCon
-- ks         == [someTypeRep @Type] :: [SomeTypeRep]
-- intRep     == typeRep @Int
-- @
--
pattern Con' :: forall k (a :: k). ()
             => NotApplication a -- See Note [Con evidence]
             => TyCon -> [SomeTypeRep] -> TypeRep a
pattern $mCon' :: forall {r} {k} {a :: k}.
TypeRep a
-> (NotApplication a => TyCon -> [SomeTypeRep] -> r)
-> ((# #) -> r)
-> r
Con' con ks <- (splitApp -> IsCon con ks)

{-# COMPLETE App, Con  #-}
{-# COMPLETE App, Con' #-}

{- Note [Con evidence]
~~~~~~~~~~~~~~~~~~~~~~
Matching TypeRep t on Con or Con' fakes up evidence of NotApplication t.

Why should anyone care about the value of strange internal type family?
Well, almost nobody cares about it, but the pattern checker does!
For example, suppose we have TypeRep (f x) and we want to get
TypeRep f and TypeRep x. There is no chance that the Con constructor
will match, because (f x) is not a constructor, but without the
NotApplication evidence, omitting it will lead to an incomplete pattern
warning. With the evidence, the pattern checker will see that
Con wouldn't typecheck, so everything works out as it should.
-}

----------------- Observation ---------------------

-- | Observe the type constructor of a quantified type representation.
someTypeRepTyCon :: SomeTypeRep -> TyCon
someTypeRepTyCon :: SomeTypeRep -> TyCon
someTypeRepTyCon (SomeTypeRep TypeRep a
t) = TypeRep a -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon TypeRep a
t

-- | Observe the type constructor of a type representation
typeRepTyCon :: TypeRep a -> TyCon
typeRepTyCon :: forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon TypeRep a
TrType = TyCon
tyConTYPE
typeRepTyCon (TrTyCon {trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon = TyCon
tc}) = TyCon
tc
typeRepTyCon (TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun = TypeRep a
a})   = TypeRep a -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon TypeRep a
a
typeRepTyCon (TrFun {})               = TypeRep (->) -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep (->) -> TyCon) -> TypeRep (->) -> TyCon
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> * -> *). Typeable a => TypeRep a
typeRep @(->)

-- | Type equality
--
-- @since base-4.10
eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
             TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
a TypeRep b
b = case (TypeRep a -> TypeRep b -> Either ((a :~~: b) -> Void) (a :~~: b))
-> TypeRep a -> TypeRep b -> Either ((a :~~: b) -> Void) (a :~~: b)
forall a. a -> a
inline TypeRep a -> TypeRep b -> Either ((a :~~: b) -> Void) (a :~~: b)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Either ((a :~~: b) -> Void) (a :~~: b)
decTypeRep TypeRep a
a TypeRep b
b of
                  -- inline: see wrinkle (I1) in Note [Inlining eqTypeRep/decTypeRep]
  Right a :~~: b
p -> (a :~~: b) -> Maybe (a :~~: b)
forall a. a -> Maybe a
Just a :~~: b
p
  Left (a :~~: b) -> Void
_  -> Maybe (a :~~: b)
forall a. Maybe a
Nothing

-- | Type equality decision
--
-- @since base-4.19.0.0
decTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
             TypeRep a -> TypeRep b -> Either (a :~~: b -> Void) (a :~~: b)
decTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Either ((a :~~: b) -> Void) (a :~~: b)
decTypeRep TypeRep a
a TypeRep b
b
  | TypeRep a -> TypeRep b -> Bool
forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Bool
sameTypeRep TypeRep a
a TypeRep b
b = (a :~~: b) -> Either ((a :~~: b) -> Void) (a :~~: b)
forall a b. b -> Either a b
Right ((Any :~~: Any) -> a :~~: b
forall a b. a -> b
unsafeCoerce Any :~~: Any
forall {k1} (a :: k1). a :~~: a
HRefl)
  | Bool
otherwise       = ((a :~~: b) -> Void) -> Either ((a :~~: b) -> Void) (a :~~: b)
forall a b. a -> Either a b
Left (\a :~~: b
HRefl -> String -> Void
forall a. String -> a
errorWithoutStackTrace (String
"decTypeRep: Impossible equality proof " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :~: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep b -> String
forall a. Show a => a -> String
show TypeRep b
b))

{-# INLINEABLE eqTypeRep #-}
{-# INLINEABLE decTypeRep #-}

{-
Note [Inlining eqTypeRep/decTypeRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We want GHC to inline eqTypeRep and decTypeRep to get rid of the Maybe
and Either in the usual case that it is scrutinized immediately. We
split them into a worker (sameTypeRep) and wrappers because otherwise
it's much larger than anything we'd want to inline.

We need INLINEABLE on the eqTypeRep and decTypeRep as GHC
seems to want to inline sameTypeRep here, making tham bigger.
By exposing exact RHS, they stay small and other optimizations may
fire first, so GHC can realise that inlining sameTypeRep is often
(but not always) a bad idea.

Wrinkle I1:

`inline decTypeRep` in eqTypeRep implementation is to ensure that `decTypeRep`
is inlined, even it's somewhat big of expression, but we know that big Left
branch will be optimized away.

See discussion in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9524
and also https://gitlab.haskell.org/ghc/ghc/-/issues/22635

-}

sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
               TypeRep a -> TypeRep b -> Bool
sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Bool
sameTypeRep TypeRep a
a TypeRep b
b = TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
a Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep b -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep b
b

-------------------------------------------------------------
--
--      Computing kinds
--
-------------------------------------------------------------

-- | Observe the kind of a type.
typeRepKind :: TypeRep (a :: k) -> TypeRep k
typeRepKind :: forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
TrType = TypeRep k
TypeRep (*)
TrType
typeRepKind (TrTyCon {trTyConKind :: forall k (a :: k). TypeRep a -> TypeRep k
trTyConKind = TypeRep k
kind}) = TypeRep k
kind
typeRepKind (TrApp {trAppKind :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep k2
trAppKind = TypeRep k
kind}) = TypeRep k
kind
typeRepKind (TrFun {}) = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Type

tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep
tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep
tyConKind (TyCon Word64#
_ Word64#
_ Module
_ TrName
_ Int#
nKindVars# KindRep
kindRep) [SomeTypeRep]
kindVars =
    let kindVarsArr :: A.Array KindBndr SomeTypeRep
        kindVarsArr :: Array Int SomeTypeRep
kindVarsArr = (Int, Int) -> [SomeTypeRep] -> Array Int SomeTypeRep
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0, Int# -> Int
I# (Int#
nKindVars# Int# -> Int# -> Int#
-# Int#
1#)) [SomeTypeRep]
kindVars
    in Array Int SomeTypeRep -> KindRep -> SomeTypeRep
instantiateKindRep Array Int SomeTypeRep
kindVarsArr KindRep
kindRep

instantiateKindRep :: A.Array KindBndr SomeTypeRep -> KindRep -> SomeTypeRep
instantiateKindRep :: Array Int SomeTypeRep -> KindRep -> SomeTypeRep
instantiateKindRep Array Int SomeTypeRep
vars = KindRep -> SomeTypeRep
go
  where
    go :: KindRep -> SomeTypeRep
    go :: KindRep -> SomeTypeRep
go (KindRepTyConApp TyCon
tc [KindRep]
args)
      = let n_kind_args :: Int
n_kind_args = TyCon -> Int
tyConKindArgs TyCon
tc
            ([KindRep]
kind_args, [KindRep]
ty_args) = Int -> [KindRep] -> ([KindRep], [KindRep])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_kind_args [KindRep]
args
            -- First instantiate tycon kind arguments
            tycon_app :: SomeTypeRep
tycon_app = TypeRep Any -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep Any -> SomeTypeRep) -> TypeRep Any -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TyCon -> [SomeTypeRep] -> TypeRep Any
forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon TyCon
tc ((KindRep -> SomeTypeRep) -> [KindRep] -> [SomeTypeRep]
forall a b. (a -> b) -> [a] -> [b]
map KindRep -> SomeTypeRep
go [KindRep]
kind_args)
            -- Then apply remaining type arguments
            applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
            applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
applyTy (SomeTypeRep TypeRep a
acc) KindRep
ty
              | SomeTypeRep TypeRep a
ty' <- KindRep -> SomeTypeRep
go KindRep
ty
              = TypeRep (Any a) -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep (Any a) -> SomeTypeRep) -> TypeRep (Any a) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep Any -> TypeRep a -> TypeRep (Any a)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp (TypeRep a -> TypeRep Any
forall a b. a -> b
unsafeCoerce TypeRep a
acc) TypeRep a
ty'
        in (SomeTypeRep -> KindRep -> SomeTypeRep)
-> SomeTypeRep -> [KindRep] -> SomeTypeRep
forall a b. (b -> a -> b) -> b -> [a] -> b
foldl' SomeTypeRep -> KindRep -> SomeTypeRep
applyTy SomeTypeRep
tycon_app [KindRep]
ty_args
    go (KindRepVar Int
var)
      = Array Int SomeTypeRep
vars Array Int SomeTypeRep -> Int -> SomeTypeRep
forall i e. Ix i => Array i e -> i -> e
A.! Int
var
    go (KindRepApp KindRep
f KindRep
a)
      = TypeRep (Any Any) -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep (Any Any) -> SomeTypeRep)
-> TypeRep (Any Any) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep Any -> TypeRep Any -> TypeRep (Any Any)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp (SomeTypeRep -> TypeRep Any
forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep -> TypeRep Any) -> SomeTypeRep -> TypeRep Any
forall a b. (a -> b) -> a -> b
$ KindRep -> SomeTypeRep
go KindRep
f) (SomeTypeRep -> TypeRep Any
forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep -> TypeRep Any) -> SomeTypeRep -> TypeRep Any
forall a b. (a -> b) -> a -> b
$ KindRep -> SomeTypeRep
go KindRep
a)
    go (KindRepFun KindRep
a KindRep
b)
      = TypeRep (Any -> Any) -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep (Any -> Any) -> SomeTypeRep)
-> TypeRep (Any -> Any) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep 'Many -> TypeRep Any -> TypeRep Any -> TypeRep (Any -> Any)
forall (m :: Multiplicity) a b.
TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a %m -> b)
mkTrFun TypeRep 'Many
trMany (SomeTypeRep -> TypeRep Any
forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep -> TypeRep Any) -> SomeTypeRep -> TypeRep Any
forall a b. (a -> b) -> a -> b
$ KindRep -> SomeTypeRep
go KindRep
a) (SomeTypeRep -> TypeRep Any
forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep -> TypeRep Any) -> SomeTypeRep -> TypeRep Any
forall a b. (a -> b) -> a -> b
$ KindRep -> SomeTypeRep
go KindRep
b)
    go (KindRepTYPE (BoxedRep Levity
Lifted)) = TypeRep (*) -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep (*)
TrType
    go (KindRepTYPE RuntimeRep
r) = SomeKindedTypeRep (*) -> SomeTypeRep
forall k. SomeKindedTypeRep k -> SomeTypeRep
unkindedTypeRep (SomeKindedTypeRep (*) -> SomeTypeRep)
-> SomeKindedTypeRep (*) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ SomeKindedTypeRep (RuntimeRep -> *)
tYPE SomeKindedTypeRep (RuntimeRep -> *)
-> SomeKindedTypeRep RuntimeRep -> SomeKindedTypeRep (*)
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep RuntimeRep
r
    go (KindRepTypeLitS TypeLitSort
sort Addr#
s)
      = TypeLitSort -> String -> SomeTypeRep
mkTypeLitFromString TypeLitSort
sort (Addr# -> String
unpackCStringUtf8# Addr#
s)
    go (KindRepTypeLitD TypeLitSort
sort String
s)
      = TypeLitSort -> String -> SomeTypeRep
mkTypeLitFromString TypeLitSort
sort String
s

    tYPE :: SomeKindedTypeRep (RuntimeRep -> *)
tYPE = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @(RuntimeRep -> Type) @TYPE

unsafeCoerceRep :: SomeTypeRep -> TypeRep a
unsafeCoerceRep :: forall {k} (a :: k). SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep TypeRep a
r) = TypeRep a -> TypeRep a
forall a b. a -> b
unsafeCoerce TypeRep a
r

unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep
unkindedTypeRep :: forall k. SomeKindedTypeRep k -> SomeTypeRep
unkindedTypeRep (SomeKindedTypeRep TypeRep a
x) = TypeRep a -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
x

data SomeKindedTypeRep k where
    SomeKindedTypeRep :: forall k (a :: k). TypeRep a
                      %1 -> SomeKindedTypeRep k

kApp :: SomeKindedTypeRep (k -> k')
     -> SomeKindedTypeRep k
     -> SomeKindedTypeRep k'
kApp :: forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
kApp (SomeKindedTypeRep TypeRep a
f) (SomeKindedTypeRep TypeRep a
a) =
    TypeRep (a a) -> SomeKindedTypeRep k'
forall k (m :: k). TypeRep m -> SomeKindedTypeRep k
SomeKindedTypeRep (TypeRep a -> TypeRep a -> TypeRep (a a)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep a
f TypeRep a
a)

kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep = TypeRep a -> SomeKindedTypeRep k
forall k (m :: k). TypeRep m -> SomeKindedTypeRep k
SomeKindedTypeRep (forall (a :: k). Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a)

buildList :: forall k. Typeable k
          => [SomeKindedTypeRep k]
          -> SomeKindedTypeRep [k]
buildList :: forall k.
Typeable k =>
[SomeKindedTypeRep k] -> SomeKindedTypeRep [k]
buildList = (SomeKindedTypeRep k
 -> SomeKindedTypeRep [k] -> SomeKindedTypeRep [k])
-> SomeKindedTypeRep [k]
-> [SomeKindedTypeRep k]
-> SomeKindedTypeRep [k]
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr SomeKindedTypeRep k
-> SomeKindedTypeRep [k] -> SomeKindedTypeRep [k]
forall {k}.
Typeable k =>
SomeKindedTypeRep k
-> SomeKindedTypeRep [k] -> SomeKindedTypeRep [k]
cons SomeKindedTypeRep [k]
nil
  where
    nil :: SomeKindedTypeRep [k]
nil = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @[k] @'[]
    cons :: SomeKindedTypeRep k
-> SomeKindedTypeRep [k] -> SomeKindedTypeRep [k]
cons SomeKindedTypeRep k
x SomeKindedTypeRep [k]
rest = TypeRep (':) -> SomeKindedTypeRep (k -> [k] -> [k])
forall k (m :: k). TypeRep m -> SomeKindedTypeRep k
SomeKindedTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: k -> [k] -> [k]). Typeable a => TypeRep a
typeRep @'(:)) SomeKindedTypeRep (k -> [k] -> [k])
-> SomeKindedTypeRep k -> SomeKindedTypeRep ([k] -> [k])
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` SomeKindedTypeRep k
x SomeKindedTypeRep ([k] -> [k])
-> SomeKindedTypeRep [k] -> SomeKindedTypeRep [k]
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` SomeKindedTypeRep [k]
rest

runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep RuntimeRep
r =
    case RuntimeRep
r of
      BoxedRep Levity
Lifted -> TypeRep LiftedRep -> SomeKindedTypeRep RuntimeRep
forall k (m :: k). TypeRep m -> SomeKindedTypeRep k
SomeKindedTypeRep TypeRep LiftedRep
trLiftedRep
      BoxedRep Levity
v  -> forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @_ @'BoxedRep
                     SomeKindedTypeRep (Levity -> RuntimeRep)
-> SomeKindedTypeRep Levity -> SomeKindedTypeRep RuntimeRep
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` Levity -> SomeKindedTypeRep Levity
levityTypeRep Levity
v
      VecRep VecCount
c VecElem
e  -> forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @_ @'VecRep
                     SomeKindedTypeRep (VecCount -> VecElem -> RuntimeRep)
-> SomeKindedTypeRep VecCount
-> SomeKindedTypeRep (VecElem -> RuntimeRep)
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` VecCount -> SomeKindedTypeRep VecCount
vecCountTypeRep VecCount
c
                     SomeKindedTypeRep (VecElem -> RuntimeRep)
-> SomeKindedTypeRep VecElem -> SomeKindedTypeRep RuntimeRep
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` VecElem -> SomeKindedTypeRep VecElem
vecElemTypeRep VecElem
e
      TupleRep [RuntimeRep]
rs -> forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @_ @'TupleRep
                     SomeKindedTypeRep ([RuntimeRep] -> RuntimeRep)
-> SomeKindedTypeRep [RuntimeRep] -> SomeKindedTypeRep RuntimeRep
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` [SomeKindedTypeRep RuntimeRep] -> SomeKindedTypeRep [RuntimeRep]
forall k.
Typeable k =>
[SomeKindedTypeRep k] -> SomeKindedTypeRep [k]
buildList ((RuntimeRep -> SomeKindedTypeRep RuntimeRep)
-> [RuntimeRep] -> [SomeKindedTypeRep RuntimeRep]
forall a b. (a -> b) -> [a] -> [b]
map RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep [RuntimeRep]
rs)
      SumRep [RuntimeRep]
rs   -> forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @_ @'SumRep
                     SomeKindedTypeRep ([RuntimeRep] -> RuntimeRep)
-> SomeKindedTypeRep [RuntimeRep] -> SomeKindedTypeRep RuntimeRep
forall k k'.
SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k -> SomeKindedTypeRep k'
`kApp` [SomeKindedTypeRep RuntimeRep] -> SomeKindedTypeRep [RuntimeRep]
forall k.
Typeable k =>
[SomeKindedTypeRep k] -> SomeKindedTypeRep [k]
buildList ((RuntimeRep -> SomeKindedTypeRep RuntimeRep)
-> [RuntimeRep] -> [SomeKindedTypeRep RuntimeRep]
forall a b. (a -> b) -> [a] -> [b]
map RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep [RuntimeRep]
rs)
      RuntimeRep
IntRep      -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'IntRep
      RuntimeRep
Int8Rep     -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Int8Rep
      RuntimeRep
Int16Rep    -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Int16Rep
      RuntimeRep
Int32Rep    -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Int32Rep
      RuntimeRep
Int64Rep    -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Int64Rep
      RuntimeRep
WordRep     -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'WordRep
      RuntimeRep
Word8Rep    -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Word8Rep
      RuntimeRep
Word16Rep   -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Word16Rep
      RuntimeRep
Word32Rep   -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Word32Rep
      RuntimeRep
Word64Rep   -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'Word64Rep
      RuntimeRep
AddrRep     -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'AddrRep
      RuntimeRep
FloatRep    -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'FloatRep
      RuntimeRep
DoubleRep   -> Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep @'DoubleRep
  where
    rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep
    rep :: Typeable LiftedRep => SomeKindedTypeRep RuntimeRep
rep = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @RuntimeRep @a

levityTypeRep :: Levity -> SomeKindedTypeRep Levity
levityTypeRep :: Levity -> SomeKindedTypeRep Levity
levityTypeRep Levity
c =
    case Levity
c of
      Levity
Lifted   -> Typeable 'Lifted => SomeKindedTypeRep Levity
rep @'Lifted
      Levity
Unlifted -> Typeable 'Lifted => SomeKindedTypeRep Levity
rep @'Unlifted
  where
    rep :: forall (a :: Levity). Typeable a => SomeKindedTypeRep Levity
    rep :: Typeable 'Lifted => SomeKindedTypeRep Levity
rep = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @Levity @a

vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount
vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount
vecCountTypeRep VecCount
c =
    case VecCount
c of
      VecCount
Vec2  -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec2
      VecCount
Vec4  -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec4
      VecCount
Vec8  -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec8
      VecCount
Vec16 -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec16
      VecCount
Vec32 -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec32
      VecCount
Vec64 -> forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep @'Vec64
  where
    rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
    rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @VecCount @a

vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem
vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem
vecElemTypeRep VecElem
e =
    case VecElem
e of
      VecElem
Int8ElemRep     -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Int8ElemRep
      VecElem
Int16ElemRep    -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Int16ElemRep
      VecElem
Int32ElemRep    -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Int32ElemRep
      VecElem
Int64ElemRep    -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Int64ElemRep
      VecElem
Word8ElemRep    -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Word8ElemRep
      VecElem
Word16ElemRep   -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Word16ElemRep
      VecElem
Word32ElemRep   -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Word32ElemRep
      VecElem
Word64ElemRep   -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'Word64ElemRep
      VecElem
FloatElemRep    -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'FloatElemRep
      VecElem
DoubleElemRep   -> forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep @'DoubleElemRep
  where
    rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
    rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep = forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep @VecElem @a

bareArrow :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                    (a :: TYPE r1) (b :: TYPE r2). ()
          => TypeRep (FUN m a b)
          -> TypeRep (FUN m :: TYPE r1 -> TYPE r2 -> Type)
bareArrow :: forall (m :: Multiplicity) a b.
TypeRep (a %m -> b) -> TypeRep (FUN m)
bareArrow (TrFun Fingerprint
_ TypeRep m
m TypeRep a
a TypeRep b
b) =
    TyCon -> [SomeTypeRep] -> TypeRep (FUN m)
forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon TyCon
funTyCon [TypeRep m -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep m
m, TypeRep r1 -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep r1
rep1, TypeRep r2 -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep r2
rep2]
  where
    rep1 :: TypeRep r1
rep1 = TypeRep (TYPE r1) -> TypeRep r1
TypeRep (*) -> TypeRep LiftedRep
getRuntimeRep (TypeRep (TYPE r1) -> TypeRep r1)
-> TypeRep (TYPE r1) -> TypeRep r1
forall a b. (a -> b) -> a -> b
$ TypeRep a -> TypeRep (TYPE r1)
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
TypeRep a
a :: TypeRep r1
    rep2 :: TypeRep r2
rep2 = TypeRep (TYPE r2) -> TypeRep r2
TypeRep (*) -> TypeRep LiftedRep
getRuntimeRep (TypeRep (TYPE r2) -> TypeRep r2)
-> TypeRep (TYPE r2) -> TypeRep r2
forall a b. (a -> b) -> a -> b
$ TypeRep b -> TypeRep (TYPE r2)
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep b
TypeRep b
b :: TypeRep r2
bareArrow TypeRep (a %m -> b)
_ = String -> TypeRep (FUN m)
forall a. HasCallStack => String -> a
error String
"Data.Typeable.Internal.bareArrow: impossible"

data IsTYPE (a :: Type) where
    IsTYPE :: forall (r :: RuntimeRep). TypeRep r %1 -> IsTYPE (TYPE r)

-- | Is a type of the form @TYPE rep@?
isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
isTYPE :: forall a. TypeRep a -> Maybe (IsTYPE a)
isTYPE TypeRep a
TrType = IsTYPE a -> Maybe (IsTYPE a)
forall a. a -> Maybe a
Just (TypeRep LiftedRep -> IsTYPE (*)
TypeRep LiftedRep -> IsTYPE (*)
IsTYPE TypeRep LiftedRep
trLiftedRep)
isTYPE (TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun=TypeRep a
f, trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg=TypeRep b
r})
  | Just a :~~: TYPE
HRefl <- TypeRep a
f TypeRep a -> TypeRep TYPE -> Maybe (a :~~: TYPE)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: RuntimeRep -> *). Typeable a => TypeRep a
typeRep @TYPE
  = IsTYPE a -> Maybe (IsTYPE a)
forall a. a -> Maybe a
Just (TypeRep b -> IsTYPE (TYPE b)
TypeRep LiftedRep -> IsTYPE (*)
IsTYPE TypeRep b
TypeRep b
r)
isTYPE TypeRep a
_ = Maybe (IsTYPE a)
forall a. Maybe a
Nothing

getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
getRuntimeRep :: TypeRep (*) -> TypeRep LiftedRep
getRuntimeRep TypeRep (TYPE r)
TrType = TypeRep r
TypeRep LiftedRep
trLiftedRep
getRuntimeRep (TrApp {trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg=TypeRep b
r}) = TypeRep b
TypeRep r
r
getRuntimeRep TypeRep (TYPE r)
_ = String -> TypeRep r
forall a. HasCallStack => String -> a
error String
"Data.Typeable.Internal.getRuntimeRep: impossible"


-------------------------------------------------------------
--
--      The Typeable class and friends
--
-------------------------------------------------------------

-- | The class 'Typeable' allows a concrete representation of a type to
-- be calculated.
class Typeable (a :: k) where
  typeRep# :: TypeRep a

typeRep :: Typeable a => TypeRep a
typeRep :: forall {k} (a :: k). Typeable a => TypeRep a
typeRep = TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep#

typeOf :: Typeable a => a -> TypeRep a
typeOf :: forall a. Typeable a => a -> TypeRep a
typeOf a
_ = TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep

-- | Takes a value of type @a@ and returns a concrete representation
-- of that type.
--
-- @since base-4.7.0.0
someTypeRep :: forall proxy a. Typeable a => proxy a -> SomeTypeRep
someTypeRep :: forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep proxy a
_ = TypeRep a -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep a)
{-# INLINE typeRep #-}

someTypeRepFingerprint :: SomeTypeRep -> Fingerprint
someTypeRepFingerprint :: SomeTypeRep -> Fingerprint
someTypeRepFingerprint (SomeTypeRep TypeRep a
t) = TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
t

----------------- Showing TypeReps --------------------

-- This follows roughly the precedence structure described in Note [Precedence
-- in types].
instance Show (TypeRep (a :: k)) where
    showsPrec :: Int -> TypeRep a -> String -> String
showsPrec = Int -> TypeRep a -> String -> String
forall k (a :: k). Int -> TypeRep a -> String -> String
showTypeable


showTypeable :: Int -> TypeRep (a :: k) -> ShowS
showTypeable :: forall k (a :: k). Int -> TypeRep a -> String -> String
showTypeable Int
_ TypeRep a
TrType = Char -> String -> String
showChar Char
'*'
showTypeable Int
_ TypeRep a
rep
  | TyCon -> Bool
isListTyCon TyCon
tc, [] <- [SomeTypeRep]
tys =
    String -> String -> String
showString String
"[]"
  | TyCon -> Bool
isListTyCon TyCon
tc, [SomeTypeRep
ty] <- [SomeTypeRep]
tys =
    Char -> String -> String
showChar Char
'[' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeRep -> String -> String
forall a. Show a => a -> String -> String
shows SomeTypeRep
ty (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
']'

    -- Take care only to render saturated tuple tycon applications
    -- with tuple notation (#14341).
  | Just (Bool
boxed, Int
n) <- TyCon -> Maybe (Bool, Int)
isTupleTyCon TyCon
tc,
    Just Bool
sat <- Bool -> Int -> Maybe Bool
plainOrSaturated Bool
boxed Int
n =
      Int -> Bool -> Bool -> String -> String
tuple Int
n Bool
boxed Bool
sat
  where
    plainOrSaturated :: Bool -> Int -> Maybe Bool
plainOrSaturated Bool
True Int
_ | Just * :~~: k
_ <- TypeRep (*)
TrType TypeRep (*) -> TypeRep k -> Maybe (* :~~: k)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
rep = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    plainOrSaturated Bool
False Int
n | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [SomeTypeRep] -> Int
forall a. [a] -> Int
length [SomeTypeRep]
tys = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    plainOrSaturated Bool
_ Int
_ | [] <- [SomeTypeRep]
tys = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    plainOrSaturated Bool
_ Int
_ | Bool
otherwise = Maybe Bool
forall a. Maybe a
Nothing

    (TyCon
tc, [SomeTypeRep]
tys) = TypeRep a -> (TyCon, [SomeTypeRep])
forall {k} (a :: k). TypeRep a -> (TyCon, [SomeTypeRep])
splitApps TypeRep a
rep

    tuple :: Int -> Bool -> Bool -> String -> String
tuple Int
n Bool
boxed Bool
sat =
      let
        (String
lpar, String
rpar) = case Bool
boxed of
          Bool
True -> (String
"(", String
")")
          Bool
False -> (String
"(#", String
"#)")
        commas :: String -> String
commas = String -> String -> String
showString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',')
        args :: String -> String
args = (String -> String) -> [SomeTypeRep] -> String -> String
forall a. Show a => (String -> String) -> [a] -> String -> String
showArgs (String -> String -> String
showString String
",") [SomeTypeRep]
tys
        args' :: String -> String
args' = case (Bool
boxed, Bool
sat) of
          (Bool
True, Bool
True) -> String -> String
args
          (Bool
False, Bool
True) -> Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
args (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' '
          (Bool
_, Bool
False) -> String -> String
commas
      in String -> String -> String
showString String
lpar (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
args' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
rpar

showTypeable Int
_ (TrTyCon {trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon = TyCon
tycon, trKindVars :: forall k (a :: k). TypeRep a -> [SomeTypeRep]
trKindVars = []})
  = TyCon -> String -> String
showTyCon TyCon
tycon
showTypeable Int
p (TrTyCon {trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon = TyCon
tycon, trKindVars :: forall k (a :: k). TypeRep a -> [SomeTypeRep]
trKindVars = [SomeTypeRep]
args})
  = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    TyCon -> String -> String
showTyCon TyCon
tycon (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String -> String) -> [SomeTypeRep] -> String -> String
forall a. Show a => (String -> String) -> [a] -> String -> String
showArgs (Char -> String -> String
showChar Char
' ') [SomeTypeRep]
args
showTypeable Int
p (TrFun {trFunArg :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep LiftedRep
trFunArg = TypeRep a
x, trFunRes :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep b
trFunRes = TypeRep b
r})
  = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    Int -> TypeRep a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
9 TypeRep a
x (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" -> " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep b -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 TypeRep b
r
showTypeable Int
p (TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun = TypeRep a
f, trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg = TypeRep b
x})
  = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    Int -> TypeRep a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 TypeRep a
f (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Int -> TypeRep b -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
10 TypeRep b
x

-- | @since base-4.10.0.0
instance Show SomeTypeRep where
  showsPrec :: Int -> SomeTypeRep -> String -> String
showsPrec Int
p (SomeTypeRep TypeRep a
ty) = Int -> TypeRep a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
p TypeRep a
ty

splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
splitApps :: forall {k} (a :: k). TypeRep a -> (TyCon, [SomeTypeRep])
splitApps = [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
forall {k} (a :: k).
[SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go []
  where
    go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
    go :: forall {k} (a :: k).
[SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go [SomeTypeRep]
xs (TrTyCon {trTyCon :: forall k (a :: k). TypeRep a -> TyCon
trTyCon = TyCon
tc})
      = (TyCon
tc, [SomeTypeRep]
xs)
    go [SomeTypeRep]
xs (TrApp {trAppFun :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep a
trAppFun = TypeRep a
f, trAppArg :: forall m k2 (a :: m -> k2) (x :: m). TypeRep (a x) -> TypeRep x
trAppArg = TypeRep b
x})
      = [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
forall {k} (a :: k).
[SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go (TypeRep b -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
x SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: [SomeTypeRep]
xs) TypeRep a
f
    go [] (TrFun {trFunArg :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep LiftedRep
trFunArg = TypeRep a
a, trFunRes :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep b
trFunRes = TypeRep b
b, trFunMul :: forall (m :: Multiplicity) a b.
TypeRep (LiftedRep %m -> b) -> TypeRep m
trFunMul = TypeRep m
mul})
      | Just 'Many :~~: m
HRefl <- TypeRep 'Many -> TypeRep m -> Maybe ('Many :~~: m)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep 'Many
trMany TypeRep m
mul = (TyCon
funTyCon, [TypeRep a -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
a, TypeRep b -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
b])
      | Bool
otherwise = String -> (TyCon, [SomeTypeRep])
forall a. String -> a
errorWithoutStackTrace String
"Data.Typeable.Internal.splitApps: Only unrestricted functions are supported"
    go [SomeTypeRep]
_  (TrFun {})
      = String -> (TyCon, [SomeTypeRep])
forall a. String -> a
errorWithoutStackTrace String
"Data.Typeable.Internal.splitApps: Impossible 1"
    go [] TypeRep a
TrType = (TyCon
tyConTYPE, [TypeRep LiftedRep -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep LiftedRep
trLiftedRep])
    go [SomeTypeRep]
_ TypeRep a
TrType
      = String -> (TyCon, [SomeTypeRep])
forall a. String -> a
errorWithoutStackTrace String
"Data.Typeable.Internal.splitApps: Impossible 2"

-- This is incredibly shady! We don't really want to do this here; we
-- should really have the compiler reveal the TYPE TyCon directly
-- somehow. We need to construct this by hand because otherwise
-- we end up with horrible and somewhat mysterious loops trying to calculate
-- typeRep @TYPE. For the moment, we use the fact that we can get the proper
-- name of the ghc-prim package from the TyCon of LiftedRep (which we can
-- produce a TypeRep for without difficulty), and then just substitute in the
-- appropriate module and constructor names.
--
-- Prior to the introduction of BoxedRep, this was bad, but now it is
-- even worse! We have to construct several different TyCons by hand
-- so that we can build the fingerprint for TYPE ('BoxedRep 'LiftedRep).
-- If we call `typeRep @('BoxedRep 'LiftedRep)` while trying to compute
-- the fingerprint of `TYPE ('BoxedRep 'LiftedRep)`, we get a loop.
--
-- The ticket to find a better way to deal with this is
-- #14480.

tyConRuntimeRep :: TyCon
tyConRuntimeRep :: TyCon
tyConRuntimeRep = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
ghcPrimPackage String
"GHC.Types" String
"RuntimeRep" Int
0
  (RuntimeRep -> KindRep
KindRepTYPE (Levity -> RuntimeRep
BoxedRep Levity
Lifted))

tyConTYPE :: TyCon
tyConTYPE :: TyCon
tyConTYPE = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
ghcPrimPackage String
"GHC.Prim" String
"TYPE" Int
0
    (KindRep -> KindRep -> KindRep
KindRepFun
      (TyCon -> [KindRep] -> KindRep
KindRepTyConApp TyCon
tyConRuntimeRep [])
      (RuntimeRep -> KindRep
KindRepTYPE (Levity -> RuntimeRep
BoxedRep Levity
Lifted))
    )

tyConLevity :: TyCon
tyConLevity :: TyCon
tyConLevity = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
ghcPrimPackage String
"GHC.Types" String
"Levity" Int
0
  (RuntimeRep -> KindRep
KindRepTYPE (Levity -> RuntimeRep
BoxedRep Levity
Lifted))

tyCon'Lifted :: TyCon
tyCon'Lifted :: TyCon
tyCon'Lifted = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
ghcPrimPackage String
"GHC.Types" String
"'Lifted" Int
0
  (TyCon -> [KindRep] -> KindRep
KindRepTyConApp TyCon
tyConLevity [])

tyCon'BoxedRep :: TyCon
tyCon'BoxedRep :: TyCon
tyCon'BoxedRep = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
ghcPrimPackage String
"GHC.Types" String
"'BoxedRep" Int
0
  (KindRep -> KindRep -> KindRep
KindRepFun (TyCon -> [KindRep] -> KindRep
KindRepTyConApp TyCon
tyConLevity []) (TyCon -> [KindRep] -> KindRep
KindRepTyConApp TyCon
tyConRuntimeRep []))

ghcPrimPackage :: String
ghcPrimPackage :: String
ghcPrimPackage = TyCon -> String
tyConPackage (TypeRep Bool -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Bool))

funTyCon :: TyCon
funTyCon :: TyCon
funTyCon = TypeRep (->) -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> * -> *). Typeable a => TypeRep a
typeRep @(->))

isListTyCon :: TyCon -> Bool
isListTyCon :: TyCon -> Bool
isListTyCon TyCon
tc = TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep [] -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep []
forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep [])

isTupleTyCon :: TyCon -> Maybe (Bool, Int)
isTupleTyCon :: TyCon -> Maybe (Bool, Int)
isTupleTyCon TyCon
tc
  | TyCon -> String
tyConPackage TyCon
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ghc-prim"
  , TyCon -> String
tyConModule  TyCon
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Tuple" Bool -> Bool -> Bool
|| TyCon -> String
tyConModule TyCon
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Types"
  = case TyCon -> String
tyConName TyCon
tc of
      String
"Unit" -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
True, Int
0)
      String
"Unit#" -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
False, Int
0)
      Char
'T' : Char
'u' : Char
'p' : Char
'l' : Char
'e' : String
arity -> String -> Maybe (Bool, Int)
readTwoDigits String
arity
      String
_ -> Maybe (Bool, Int)
forall a. Maybe a
Nothing
  | Bool
otherwise                   = Maybe (Bool, Int)
forall a. Maybe a
Nothing

-- | See Note [Small Ints parsing] in GHC.Builtin.Types
readTwoDigits :: String -> Maybe (Bool, Int)
readTwoDigits :: String -> Maybe (Bool, Int)
readTwoDigits String
s = case String
s of
  Char
c1 : String
t1 | Char -> Bool
isDigit Char
c1 -> case String
t1 of
    [] -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
True, Char -> Int
digit_to_int Char
c1)
    [Char
'#'] -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
False, Char -> Int
digit_to_int Char
c1)
    Char
c2 : String
t2 | Char -> Bool
isDigit Char
c2 ->
      let ar :: Int
ar = Char -> Int
digit_to_int Char
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digit_to_int Char
c2
      in case String
t2 of
        [] -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
True, Int
ar)
        [Char
'#'] -> (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
False, Int
ar)
        String
_ -> Maybe (Bool, Int)
forall a. Maybe a
Nothing
    String
_ -> Maybe (Bool, Int)
forall a. Maybe a
Nothing
  String
_ -> Maybe (Bool, Int)
forall a. Maybe a
Nothing
  where
    digit_to_int :: Char -> Int
    digit_to_int :: Char -> Int
digit_to_int Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'

-- This is only an approximation. We don't have the general
-- character-classification machinery here, so we just do our best.
-- This should work for promoted Haskell 98 data constructors and
-- for TypeOperators type constructors that begin with ASCII
-- characters, but it will miss Unicode operators.
--
-- If we wanted to catch Unicode as well, we ought to consider moving
-- GHC.Lexeme from ghc-boot-th to base. Then we could just say:
--
--   startsVarSym symb || startsConSym symb
--
-- But this is a fair deal of work just for one corner case, so I think I'll
-- leave it like this unless someone shouts.
isOperatorTyCon :: TyCon -> Bool
isOperatorTyCon :: TyCon -> Bool
isOperatorTyCon TyCon
tc
  | Char
symb : String
_ <- TyCon -> String
tyConName TyCon
tc
  , Char
symb Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem` String
"!#$%&*+./<=>?@\\^|-~:" = Bool
True
  | Bool
otherwise                           = Bool
False

showTyCon :: TyCon -> ShowS
showTyCon :: TyCon -> String -> String
showTyCon TyCon
tycon = Bool -> (String -> String) -> String -> String
showParen (TyCon -> Bool
isOperatorTyCon TyCon
tycon) (TyCon -> String -> String
forall a. Show a => a -> String -> String
shows TyCon
tycon)

showArgs :: Show a => ShowS -> [a] -> ShowS
showArgs :: forall a. Show a => (String -> String) -> [a] -> String -> String
showArgs String -> String
_   []     = String -> String
forall a. a -> a
id
showArgs String -> String
_   [a
a]    = Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
10 a
a
showArgs String -> String
sep (a
a:[a]
as) = Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
10 a
a (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sep (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [a] -> String -> String
forall a. Show a => (String -> String) -> [a] -> String -> String
showArgs String -> String
sep [a]
as

-- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
--
-- @since base-4.8.0.0
rnfTypeRep :: TypeRep a -> ()
-- The TypeRep structure is almost entirely strict by definition. The
-- fingerprinting and strict kind caching ensure that everything
-- else is forced anyway. So we don't need to do anything special
-- to reduce to normal form.
rnfTypeRep :: forall {k} (a :: k). TypeRep a -> ()
rnfTypeRep !TypeRep a
_ = ()

-- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@
-- implementation
--
-- @since base-4.10.0.0
rnfSomeTypeRep :: SomeTypeRep -> ()
rnfSomeTypeRep :: SomeTypeRep -> ()
rnfSomeTypeRep (SomeTypeRep TypeRep a
r) = TypeRep a -> ()
forall {k} (a :: k). TypeRep a -> ()
rnfTypeRep TypeRep a
r

{- *********************************************************
*                                                          *
*       TyCon/TypeRep definitions for type literals        *
*              (Symbol and Nat)                            *
*                                                          *
********************************************************* -}

pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep
pattern $mKindRepTypeLit :: forall {r}.
KindRep -> (TypeLitSort -> String -> r) -> ((# #) -> r) -> r
$bKindRepTypeLit :: TypeLitSort -> String -> KindRep
KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t))
  where
    KindRepTypeLit TypeLitSort
sort String
t = TypeLitSort -> String -> KindRep
KindRepTypeLitD TypeLitSort
sort String
t

{-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun,
             KindRepTYPE, KindRepTypeLit #-}

getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)
getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)
getKindRepTypeLit (KindRepTypeLitS TypeLitSort
sort Addr#
t) = (TypeLitSort, String) -> Maybe (TypeLitSort, String)
forall a. a -> Maybe a
Just (TypeLitSort
sort, Addr# -> String
unpackCStringUtf8# Addr#
t)
getKindRepTypeLit (KindRepTypeLitD TypeLitSort
sort String
t) = (TypeLitSort, String) -> Maybe (TypeLitSort, String)
forall a. a -> Maybe a
Just (TypeLitSort
sort, String
t)
getKindRepTypeLit KindRep
_                        = Maybe (TypeLitSort, String)
forall a. Maybe a
Nothing

-- | Exquisitely unsafe.
mkTyCon# :: Addr#       -- ^ package name
         -> Addr#       -- ^ module name
         -> Addr#       -- ^ the name of the type constructor
         -> Int#        -- ^ number of kind variables
         -> KindRep     -- ^ kind representation
         -> TyCon       -- ^ A unique 'TyCon' object
mkTyCon# :: Addr# -> Addr# -> Addr# -> Int# -> KindRep -> TyCon
mkTyCon# Addr#
pkg Addr#
modl Addr#
name Int#
n_kinds KindRep
kind_rep
  | Fingerprint (W64# Word64#
hi) (W64# Word64#
lo) <- Fingerprint
fingerprint
  = Word64# -> Word64# -> Module -> TrName -> Int# -> KindRep -> TyCon
TyCon Word64#
hi Word64#
lo Module
mod (Addr# -> TrName
TrNameS Addr#
name) Int#
n_kinds KindRep
kind_rep
  where
    mod :: Module
mod = TrName -> TrName -> Module
Module (Addr# -> TrName
TrNameS Addr#
pkg) (Addr# -> TrName
TrNameS Addr#
modl)
    fingerprint :: Fingerprint
    fingerprint :: Fingerprint
fingerprint = String -> String -> String -> Fingerprint
mkTyConFingerprint (Addr# -> String
unpackCStringUtf8# Addr#
pkg)
                                     (Addr# -> String
unpackCStringUtf8# Addr#
modl)
                                     (Addr# -> String
unpackCStringUtf8# Addr#
name)

-- it is extremely important that this fingerprint computation
-- remains in sync with that in GHC.Tc.Instance.Typeable to ensure that type
-- equality is correct.

-- | Exquisitely unsafe.
mkTyCon :: String       -- ^ package name
        -> String       -- ^ module name
        -> String       -- ^ the name of the type constructor
        -> Int         -- ^ number of kind variables
        -> KindRep     -- ^ kind representation
        -> TyCon        -- ^ A unique 'TyCon' object
-- Used when the strings are dynamically allocated,
-- eg from binary deserialisation
mkTyCon :: String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
pkg String
modl String
name (I# Int#
n_kinds) KindRep
kind_rep
  | Fingerprint (W64# Word64#
hi) (W64# Word64#
lo) <- Fingerprint
fingerprint
  = Word64# -> Word64# -> Module -> TrName -> Int# -> KindRep -> TyCon
TyCon Word64#
hi Word64#
lo Module
mod (String -> TrName
TrNameD String
name) Int#
n_kinds KindRep
kind_rep
  where
    mod :: Module
mod = TrName -> TrName -> Module
Module (String -> TrName
TrNameD String
pkg) (String -> TrName
TrNameD String
modl)
    fingerprint :: Fingerprint
    fingerprint :: Fingerprint
fingerprint = String -> String -> String -> Fingerprint
mkTyConFingerprint String
pkg String
modl String
name

-- This must match the computation done in GHC.Tc.Instance.Typeable.mkTyConRepTyConRHS.
mkTyConFingerprint :: String -- ^ package name
                   -> String -- ^ module name
                   -> String -- ^ tycon name
                   -> Fingerprint
mkTyConFingerprint :: String -> String -> String -> Fingerprint
mkTyConFingerprint String
pkg_name String
mod_name String
tycon_name =
        [Fingerprint] -> Fingerprint
fingerprintFingerprints
        [ String -> Fingerprint
fingerprintString String
pkg_name
        , String -> Fingerprint
fingerprintString String
mod_name
        , String -> Fingerprint
fingerprintString String
tycon_name
        ]

mkTypeLitTyCon :: String -> TyCon -> TyCon
mkTypeLitTyCon :: String -> TyCon -> TyCon
mkTypeLitTyCon String
name TyCon
kind_tycon
  = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
"base" String
"GHC.TypeLits" String
name Int
0 KindRep
kind
  where kind :: KindRep
kind = TyCon -> [KindRep] -> KindRep
KindRepTyConApp TyCon
kind_tycon []

-- | Used to make `'Typeable' instance for things of kind Nat
typeNatTypeRep :: forall a. KnownNat a => TypeRep a
typeNatTypeRep :: forall (a :: Nat). KnownNat a => TypeRep a
typeNatTypeRep = String -> TyCon -> TypeRep a
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep (Nat -> String
forall a. Show a => a -> String
show (Proxy# a -> Nat
forall (n :: Nat). KnownNat n => Proxy# n -> Nat
natVal' (forall (a :: Nat). Proxy# a
forall {k} (a :: k). Proxy# a
proxy# @a))) TyCon
tcNat

-- | Used to make `'Typeable' instance for things of kind Symbol
typeSymbolTypeRep :: forall a. KnownSymbol a => TypeRep a
typeSymbolTypeRep :: forall (a :: Symbol). KnownSymbol a => TypeRep a
typeSymbolTypeRep = String -> TyCon -> TypeRep a
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep (String -> String
forall a. Show a => a -> String
show (Proxy# a -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (forall {k} (a :: k). Proxy# a
forall (a :: Symbol). Proxy# a
proxy# @a))) TyCon
tcSymbol

-- | Used to make `'Typeable' instance for things of kind Char
typeCharTypeRep :: forall a. KnownChar a => TypeRep a
typeCharTypeRep :: forall (a :: Char). KnownChar a => TypeRep a
typeCharTypeRep = String -> TyCon -> TypeRep a
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep (Char -> String
forall a. Show a => a -> String
show (Proxy# a -> Char
forall (n :: Char). KnownChar n => Proxy# n -> Char
charVal' (forall (a :: Char). Proxy# a
forall {k} (a :: k). Proxy# a
proxy# @a))) TyCon
tcChar

mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
mkTypeLitFromString TypeLitSort
TypeLitSymbol String
s =
    TypeRep Symbol -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep Symbol -> SomeTypeRep) -> TypeRep Symbol -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ (String -> TyCon -> TypeRep Symbol
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep String
s TyCon
tcSymbol :: TypeRep Symbol)
mkTypeLitFromString TypeLitSort
TypeLitNat String
s =
    TypeRep Nat -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep Nat -> SomeTypeRep) -> TypeRep Nat -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ (String -> TyCon -> TypeRep Nat
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep String
s TyCon
tcNat :: TypeRep Nat)
mkTypeLitFromString TypeLitSort
TypeLitChar String
s =
    TypeRep Char -> SomeTypeRep
forall m (a :: m). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep Char -> SomeTypeRep) -> TypeRep Char -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ (String -> TyCon -> TypeRep Char
forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep String
s TyCon
tcChar :: TypeRep Char)

tcSymbol :: TyCon
tcSymbol :: TyCon
tcSymbol = TypeRep Symbol -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Symbol)

tcNat :: TyCon
tcNat :: TyCon
tcNat = TypeRep Nat -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Nat)

tcChar :: TyCon
tcChar :: TyCon
tcChar = TypeRep Char -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Char)

-- | An internal function, to make representations for type literals.
typeLitTypeRep :: forall k (a :: k). (Typeable k) =>
                  String -> TyCon -> TypeRep a
typeLitTypeRep :: forall k (a :: k). Typeable k => String -> TyCon -> TypeRep a
typeLitTypeRep String
nm TyCon
kind_tycon = TyCon -> [SomeTypeRep] -> TypeRep a
forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon (String -> TyCon -> TyCon
mkTypeLitTyCon String
nm TyCon
kind_tycon) []

-- | For compiler use.
mkTrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                  (a :: TYPE r1) (b :: TYPE r2).
           TypeRep m -> TypeRep a -> TypeRep b -> TypeRep ((FUN m a b) :: Type)
mkTrFun :: forall (m :: Multiplicity) a b.
TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a %m -> b)
mkTrFun TypeRep m
mul TypeRep a
arg TypeRep b
res = TrFun
    { trFunFingerprint :: Fingerprint
trFunFingerprint = Fingerprint
fpr
    , trFunMul :: TypeRep m
trFunMul = TypeRep m
mul
    , trFunArg :: TypeRep a
trFunArg = TypeRep a
arg
    , trFunRes :: TypeRep b
trFunRes = TypeRep b
res }
  where fpr :: Fingerprint
fpr = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ TypeRep m -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep m
mul
                                      , TypeRep a -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep a
arg
                                      , TypeRep b -> Fingerprint
forall k (a :: k). TypeRep a -> Fingerprint
typeRepFingerprint TypeRep b
res]

{- $kind_instantiation

Consider a type like 'Data.Proxy.Proxy',

@
data Proxy :: forall k. k -> Type
@

One might think that one could decompose an instantiation of this type like
@Proxy Int@ into two applications,

@
'App' (App a b) c === typeRep @(Proxy Int)
@

where,

@
a = typeRep @Proxy
b = typeRep @Type
c = typeRep @Int
@

However, this isn't the case. Instead we can only decompose into an application
and a constructor,

@
'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int)
@

The reason for this is that 'Typeable' can only represent /kind-monomorphic/
types. That is, we must saturate enough of @Proxy@\'s arguments to
fully determine its kind. In the particular case of @Proxy@ this means we must
instantiate the kind variable @k@ such that no @forall@-quantified variables
remain.

While it is not possible to decompose the 'Con' above into an application, it is
possible to observe the kind variable instantiations of the constructor with the
'Con\'' pattern,

@
'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int)
@

Here @kinds@ will be @[typeRep \@Type]@.

-}