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

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds         #-}
#endif

#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

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

import           GHC.Exts (Char(..))
import           GHC.Prim (Addr#, (+#), 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.Monoid.Compat ((<>))
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 (Char(..))
import           GHC.Prim (Addr#, (+#), 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 = isTupleString . 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 p (SomeTypeRep ty) = showbPrec p ty

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

-- | Only available with @base-4.10.0.0@ or later.
--
-- /Since: 3.6/
instance TextShow1 TypeRep where
    liftShowbPrec _ _ = showbTypeable

showbTypeable :: Int -> TypeRep (a :: k) -> Builder
showbTypeable _ rep
  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) =
    singleton '*'
  | isListTyCon tc, [ty] <- tys =
    singleton '[' <> showb ty <> singleton ']'
  | isTupleTyCon tc =
    showbTuple tys
  where (tc, tys) = splitApps rep
showbTypeable p (Con' tycon [])
  = showbPrec p tycon
showbTypeable p (Con' tycon args)
  = showbParen (p > 9) $
    showbPrec p tycon <>
    showbSpace <>
    showbArgs showbSpace args
showbTypeable p (Fun x r)
  = showbParen (p > 8) $
    showbPrec 9 x <> " -> " <> showbPrec 8 r
showbTypeable p (App f x)
  = showbParen (p > 9) $
    showbPrec 8 f <>
    showbSpace <>
    showbPrec 10 x

splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
splitApps = go []
  where
    go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
    go xs (Con tc)  = (tc, xs)
    go xs (App f x) = go (SomeTypeRep x : xs) f
    go [] (Fun a b) = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
    go _  (Fun _ _) =
        errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible"

funTyCon :: TyCon
funTyCon = typeRepTyCon (typeRep @(->))

isListTyCon :: TyCon -> Bool
isListTyCon tc = tc == typeRepTyCon (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 p (TyCon _ _ _ tc_name _ _) = showbPrec p 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 (TrNameS s) = unpackCStringToBuilder# s
    showb (TrNameD s) = fromString 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
  = unpack 0#
  where
    unpack nh
      | isTrue# (ch `eqChar#` '\0'#) = mempty
      | True                         = singleton (C# ch) <> unpack (nh +# 1#)
      where
        !ch = indexCharOffAddr# addr nh
{-# NOINLINE unpackCStringToBuilder# #-}

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