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

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

{-# OPTIONS_GHC -Wno-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)
# if !(MIN_VERSION_base(4,20,0))
import           TextShow.Data.Typeable.Utils (showbTuple)
#endif

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 (Builder, fromString, singleton)
import           Data.Typeable (TypeRep, typeRepArgs, typeRepTyCon)
import           Data.Typeable.Internal (Proxy(..), Typeable,
                                         TypeRep(TypeRep), tyConName, typeRep,
                                         typeRepKinds)

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

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

#if MIN_VERSION_base(4,13,0)
import           Type.Reflection (typeRepKind)
#endif

#if MIN_VERSION_base(4,19,0)
import           Data.Char (isDigit, ord)
import           Type.Reflection (tyConModule, tyConPackage)
#else
import           TextShow.Utils (isTupleString)
#endif

#if !(MIN_VERSION_base(4,10,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)
#endif

-- | Does the 'TyCon' represent a tuple type constructor?
#if MIN_VERSION_base(4,20,0)
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

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'
#elif MIN_VERSION_base(4,19,0)
isTupleTyCon :: TyCon -> Maybe Int
isTupleTyCon tc
  | tyConPackage tc == "ghc-prim"
  , tyConModule  tc == "GHC.Tuple.Prim"
  = case tyConName tc of
      "Unit" -> Just 0
      'T' : 'u' : 'p' : 'l' : 'e' : arity -> readTwoDigits arity
      _ -> Nothing
  | otherwise                   = Nothing

readTwoDigits :: String -> Maybe Int
readTwoDigits s = case s of
  [c] | isDigit c -> Just (digit_to_int c)
  [c1, c2] | isDigit c1, isDigit c2
    -> Just (digit_to_int c1 * 10 + digit_to_int c2)
  _ -> Nothing
  where
    digit_to_int :: Char -> Int
    digit_to_int c = ord c - ord '0'
#else
isTupleTyCon :: TyCon -> Bool
isTupleTyCon = isTupleString . tyConName
{-# INLINE isTupleTyCon #-}
#endif

#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 :: forall a.
(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 :: forall k (a :: k). 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]
tys =
    String -> Builder
fromString String
"[]"
  | 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
']'
# if MIN_VERSION_base(4,20,0)
  | 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 -> Builder
tuple Int
n Bool
boxed Bool
sat
# elif MIN_VERSION_base(4,19,0)
  | Just _ <- isTupleTyCon tc,
    Just _ <- typeRep @Type `eqTypeRep` typeRepKind rep =
    showbTuple tys
    -- Print (,,,) instead of Tuple4
  | Just n <- isTupleTyCon tc, [] <- tys =
      singleton '(' <> fromString (replicate (n-1) ',') <> singleton ')'
# else
  | isTupleTyCon tc
#  if MIN_VERSION_base(4,13,0)
  , Just _ <- typeRep @Type `eqTypeRep` typeRepKind rep
#  endif
  = showbTuple tys
# endif
  where
    (TyCon
tc, [SomeTypeRep]
tys) = TypeRep a -> (TyCon, [SomeTypeRep])
forall {k} (a :: k). TypeRep a -> (TyCon, [SomeTypeRep])
splitApps TypeRep a
rep

# if MIN_VERSION_base(4,20,0)
    plainOrSaturated :: Bool -> Int -> Maybe Bool
plainOrSaturated Bool
True Int
_ | Just * :~~: k
_ <- forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Type 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
forall (t :: * -> *) a. Foldable t => t 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

    tuple :: Int -> Bool -> Bool -> Builder
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 :: Builder
commas = String -> Builder
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',')
        args :: Builder
args = Builder -> [SomeTypeRep] -> Builder
forall a. TextShow a => Builder -> [a] -> Builder
showbArgs (String -> Builder
fromString String
",") [SomeTypeRep]
tys
        args' :: Builder
args' = case (Bool
boxed, Bool
sat) of
          (Bool
True, Bool
True) -> Builder
args
          (Bool
False, Bool
True) -> Char -> Builder
singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
args Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
' '
          (Bool
_, Bool
False) -> Builder
commas
      in String -> Builder
fromString String
lpar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
args' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
rpar
# endif
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 :: 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 [] (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 (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 [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@.
--
-- /Since: 2/
instance TextShow TypeRep where
    showbPrec p tyrep =
        case tys of
          [] -> showb tycon
          [x@(TypeRep _ argCon _ _)]
            | tycon == tcList -> singleton '[' <> showb x <> singleton ']'
            | tycon == tcTYPE && argCon == tc'Lifted   -> singleton '*'
            | tycon == tcTYPE && argCon == tc'Unlifted -> singleton '#'
          [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 (kinds ++ tys)
      where
        tycon = typeRepTyCon tyrep
        tys   = typeRepArgs tyrep
        kinds = typeRepKinds tyrep
#endif

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

-- | /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# #-}

-- | /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 #-}