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

readTwoDigits :: String -> Maybe (Bool, Int)
readTwoDigits s = case s of
  c1 : t1 | isDigit c1 -> case t1 of
    [] -> Just (True, digit_to_int c1)
    ['#'] -> Just (False, digit_to_int c1)
    c2 : t2 | isDigit c2 ->
      let ar = digit_to_int c1 * 10 + digit_to_int c2
      in case t2 of
        [] -> Just (True, ar)
        ['#'] -> Just (False, ar)
        _ -> Nothing
    _ -> Nothing
  _ -> Nothing
  where
    digit_to_int :: Char -> Int
    digit_to_int c = ord c - ord '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 :: 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 #-}
#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 (boxed, n) <- isTupleTyCon tc,
    Just sat <- plainOrSaturated boxed n =
      tuple n boxed 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
  | TyCon -> Bool
isTupleTyCon TyCon
tc
#  if MIN_VERSION_base(4,13,0)
  , 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
#  endif
  = [SomeTypeRep] -> Builder
forall a. TextShow a => [a] -> Builder
showbTuple [SomeTypeRep]
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 True _ | Just _ <- typeRep @Type `eqTypeRep` typeRepKind rep = Just True
    plainOrSaturated False n | n == length tys = Just True
    plainOrSaturated _ _ | [] <- tys = Just False
    plainOrSaturated _ _ | otherwise = Nothing

    tuple n boxed sat =
      let
        (lpar, rpar) = case boxed of
          True -> ("(", ")")
          False -> ("(#", "#)")
        commas = fromString (replicate (n-1) ',')
        args = showbArgs (fromString ",") tys
        args' = case (boxed, sat) of
          (True, True) -> args
          (False, True) -> singleton ' ' <> args <> singleton ' '
          (_, False) -> commas
      in fromString lpar <> args' <> fromString 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@ 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 Word64#
_ Word64#
_ 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