{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE OverloadedStrings #-}

#if __GLASGOW_HASKELL__ >= 801
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeApplications  #-}
#endif

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|
Module:      TextShow.Data.Typeable
Copyright:   (C) 2014-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

'TextShow' instances for data types in the @Typeable@ module.

/Since: 2/
-}
module TextShow.Data.Typeable () where

import           Prelude ()
import           Prelude.Compat

#if MIN_VERSION_base(4,10,0)
import           Data.Kind (Type)
import           Data.Text.Lazy.Builder (Builder, fromString, singleton)
import           Data.Type.Equality ((:~~:)(..))

import           GHC.Exts (Addr#, Char(..), (+#), eqChar#, indexCharOffAddr#)
import           GHC.Types (Module(..), TrName(..), TyCon(..), isTrue#)

import           TextShow.Classes (TextShow(..), TextShow1(..), showbParen, showbSpace)
import           TextShow.Data.Typeable.Utils (showbArgs, showbTuple)
import           TextShow.Utils (isTupleString)

import           Type.Reflection (pattern App, pattern Con, pattern Con', pattern Fun,
                                  SomeTypeRep(..), TypeRep,
                                  eqTypeRep, tyConName, typeRep, typeRepTyCon)
#else /* !(MIN_VERSION_base(4,10,0) */
import           Data.Text.Lazy.Builder (fromString, singleton)
import           Data.Typeable (TypeRep, typeRepArgs, typeRepTyCon)
import           Data.Typeable.Internal (tyConName)
# if MIN_VERSION_base(4,8,0)
import           Data.Typeable.Internal (typeRepKinds)
# endif
# if MIN_VERSION_base(4,9,0)
import           Data.Text.Lazy.Builder (Builder)
import           Data.Typeable.Internal (Proxy(..), Typeable,
                                         TypeRep(TypeRep), typeRep)
import           GHC.Exts (RuntimeRep(..), TYPE)
# else
import           Data.Typeable.Internal (funTc, listTc)
# endif

# if MIN_VERSION_base(4,9,0)
import           GHC.Exts (Addr#, Char(..), (+#), eqChar#, indexCharOffAddr#)
import           GHC.Types (TyCon(..), TrName(..), Module(..), isTrue#)
# else
import           Data.Typeable.Internal (TyCon)
# endif

import           TextShow.Classes (TextShow(..), showbParen, showbSpace)
import           TextShow.Data.List ()
import           TextShow.Data.Typeable.Utils (showbArgs, showbTuple)
import           TextShow.Utils (isTupleString)
#endif

#if !(MIN_VERSION_base(4,10,0))
# if MIN_VERSION_base(4,9,0)
tyConOf :: Typeable a => Proxy a -> TyCon
tyConOf = typeRepTyCon . typeRep

tcFun :: TyCon
tcFun = tyConOf (Proxy :: Proxy (Int -> Int))

tcList :: TyCon
tcList = tyConOf (Proxy :: Proxy [])

tcTYPE :: TyCon
tcTYPE = tyConOf (Proxy :: Proxy TYPE)

tc'Lifted :: TyCon
tc'Lifted = tyConOf (Proxy :: Proxy 'PtrRepLifted)

tc'Unlifted :: TyCon
tc'Unlifted = tyConOf (Proxy :: Proxy 'PtrRepUnlifted)
# else
-- | The list 'TyCon'.
tcList :: TyCon
tcList = listTc

-- | The function (@->@) 'TyCon'.
tcFun :: TyCon
tcFun = funTc
# endif
#endif

-- | Does the 'TyCon' represent a tuple type constructor?
isTupleTyCon :: TyCon -> Bool
isTupleTyCon :: TyCon -> Bool
isTupleTyCon = String -> Bool
isTupleString (String -> Bool) -> (TyCon -> String) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
tyConName
{-# INLINE isTupleTyCon #-}

#if MIN_VERSION_base(4,10,0)
-- | Only available with @base-4.10.0.0@ or later.
--
-- /Since: 3.6/
instance TextShow SomeTypeRep where
    showbPrec :: Int -> SomeTypeRep -> Builder
showbPrec Int
p (SomeTypeRep TypeRep a
ty) = Int -> TypeRep a -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
p TypeRep a
ty

-- | Only available with @base-4.10.0.0@ or later.
--
-- /Since: 3.6/
instance TextShow (TypeRep (a :: k)) where
    showbPrec :: Int -> TypeRep a -> Builder
showbPrec = Int -> TypeRep a -> Builder
forall k (a :: k). Int -> TypeRep a -> Builder
showbTypeable

-- | Only available with @base-4.10.0.0@ or later.
--
-- /Since: 3.6/
instance TextShow1 TypeRep where
    liftShowbPrec :: (Int -> a -> Builder)
-> ([a] -> Builder) -> Int -> TypeRep a -> Builder
liftShowbPrec Int -> a -> Builder
_ [a] -> Builder
_ = Int -> TypeRep a -> Builder
forall k (a :: k). Int -> TypeRep a -> Builder
showbTypeable

showbTypeable :: Int -> TypeRep (a :: k) -> Builder
showbTypeable :: Int -> TypeRep a -> Builder
showbTypeable Int
_ TypeRep a
rep
  | Just a :~~: *
HRefl <- TypeRep a
rep TypeRep a -> TypeRep * -> Maybe (a :~~: *)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (TypeRep *
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type) =
    Char -> Builder
singleton Char
'*'
  | TyCon -> Bool
isListTyCon TyCon
tc, [SomeTypeRep
ty] <- [SomeTypeRep]
tys =
    Char -> Builder
singleton Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Builder
forall a. TextShow a => a -> Builder
showb SomeTypeRep
ty Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
']'
  | TyCon -> Bool
isTupleTyCon TyCon
tc =
    [SomeTypeRep] -> Builder
forall a. TextShow a => [a] -> Builder
showbTuple [SomeTypeRep]
tys
  where (TyCon
tc, [SomeTypeRep]
tys) = TypeRep a -> (TyCon, [SomeTypeRep])
forall k (a :: k). TypeRep a -> (TyCon, [SomeTypeRep])
splitApps TypeRep a
rep
showbTypeable Int
p (Con' TyCon
tycon [])
  = Int -> TyCon -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
p TyCon
tycon
showbTypeable Int
p (Con' TyCon
tycon [SomeTypeRep]
args)
  = Bool -> Builder -> Builder
showbParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Int -> TyCon -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
p TyCon
tycon Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder
showbSpace Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder -> [SomeTypeRep] -> Builder
forall a. TextShow a => Builder -> [a] -> Builder
showbArgs Builder
showbSpace [SomeTypeRep]
args
showbTypeable Int
p (Fun TypeRep arg
x TypeRep res
r)
  = Bool -> Builder -> Builder
showbParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Int -> TypeRep arg -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
9 TypeRep arg
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> TypeRep res -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
8 TypeRep res
r
showbTypeable Int
p (App TypeRep a
f TypeRep b
x)
  = Bool -> Builder -> Builder
showbParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Int -> TypeRep a -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
8 TypeRep a
f Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder
showbSpace Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Int -> TypeRep b -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
10 TypeRep b
x

splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
splitApps :: 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 :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go [] (Fun TypeRep arg
a TypeRep res
b) = (TyCon
funTyCon, [TypeRep arg -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep arg
a, TypeRep res -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
b])
    go [SomeTypeRep]
_  (Fun TypeRep arg
_ TypeRep res
_) =
        String -> (TyCon, [SomeTypeRep])
forall a. String -> a
errorWithoutStackTrace String
"Data.Typeable.Internal.splitApps: Impossible"
    go [SomeTypeRep]
xs (Con TyCon
tc)  = (TyCon
tc, [SomeTypeRep]
xs)
    go [SomeTypeRep]
xs (App TypeRep a
f TypeRep b
x) = [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
forall k (a :: k).
[SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
x SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: [SomeTypeRep]
xs) TypeRep a
f

funTyCon :: TyCon
funTyCon :: TyCon
funTyCon = TypeRep (->) -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (Typeable (->) => TypeRep (->)
forall k (a :: k). 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 [Int] -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep [Int]
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep [Int])
#else
-- | Only available with @base-4.9@ or earlier.
--
-- /Since: 2/
instance TextShow TypeRep where
    showbPrec p tyrep =
        case tys of
          [] -> showb tycon
# if MIN_VERSION_base(4,9,0)
          [x@(TypeRep _ argCon _ _)]
# else
          [x]
# endif
            | tycon == tcList -> singleton '[' <> showb x <> singleton ']'
# if MIN_VERSION_base(4,9,0)
            | tycon == tcTYPE && argCon == tc'Lifted   -> singleton '*'
            | tycon == tcTYPE && argCon == tc'Unlifted -> singleton '#'
# endif
          [a,r] | tycon == tcFun  -> showbParen (p > 8) $
                                        showbPrec 9 a
                                     <> " -> "
                                     <> showbPrec 8 r
          xs | isTupleTyCon tycon -> showbTuple xs
             | otherwise          -> showbParen (p > 9) $
                                        showbPrec p tycon
                                     <> showbSpace
                                     <> showbArgs showbSpace
# if MIN_VERSION_base(4,8,0)
                                                             (kinds ++ tys)
# else
                                                             tys
# endif
      where
        tycon = typeRepTyCon tyrep
        tys   = typeRepArgs tyrep
# if MIN_VERSION_base(4,8,0)
        kinds = typeRepKinds tyrep
# endif
#endif

-- | /Since: 2/
instance TextShow TyCon where
#if MIN_VERSION_base(4,10,0)
    showbPrec :: Int -> TyCon -> Builder
showbPrec Int
p (TyCon Word#
_ Word#
_ Module
_ TrName
tc_name Int#
_ KindRep
_) = Int -> TrName -> Builder
forall a. TextShow a => Int -> a -> Builder
showbPrec Int
p TrName
tc_name
#elif MIN_VERSION_base(4,9,0)
    showb (TyCon _ _ _ tc_name) = showb tc_name
#else
    showb = fromString . tyConName
#endif

#if MIN_VERSION_base(4,9,0)
-- | Only available with @base-4.9.0.0@ or later.
--
-- /Since: 3/
instance TextShow TrName where
    showb :: TrName -> Builder
showb (TrNameS Addr#
s) = Addr# -> Builder
unpackCStringToBuilder# Addr#
s
    showb (TrNameD String
s) = String -> Builder
fromString String
s
    {-# INLINE showb #-}

unpackCStringToBuilder# :: Addr# -> Builder
    -- There's really no point in inlining this, ever, as the loop doesn't
    -- specialise in an interesting But it's pretty small, so there's a danger
    -- that it'll be inlined at every literal, which is a waste
unpackCStringToBuilder# :: Addr# -> Builder
unpackCStringToBuilder# Addr#
addr
  = Int# -> Builder
unpack Int#
0#
  where
    unpack :: Int# -> Builder
unpack Int#
nh
      | Int# -> Bool
isTrue# (Char#
ch Char# -> Char# -> Int#
`eqChar#` Char#
'\0'#) = Builder
forall a. Monoid a => a
mempty
      | Bool
True                         = Char -> Builder
singleton (Char# -> Char
C# Char#
ch) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int# -> Builder
unpack (Int#
nh Int# -> Int# -> Int#
+# Int#
1#)
      where
        !ch :: Char#
ch = Addr# -> Int# -> Char#
indexCharOffAddr# Addr#
addr Int#
nh
{-# NOINLINE unpackCStringToBuilder# #-}

-- | Only available with @base-4.9.0.0@ or later.
--
-- /Since: 3/
instance TextShow Module where
    showb :: Module -> Builder
showb (Module TrName
p TrName
m) = TrName -> Builder
forall a. TextShow a => a -> Builder
showb TrName
p Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TrName -> Builder
forall a. TextShow a => a -> Builder
showb TrName
m
    {-# INLINE showb #-}
#endif