{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}

-- |
--  Utility functions to display or manipulate types
module Data.Registry.Internal.Reflection where

import Data.Semigroup
import Data.Text as T
import Data.Typeable (splitTyConApp)
import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>))

import GHC.Exts
import Type.Reflection as Reflection

-- | Return true if the type of this type rep represents a function
isFunction :: SomeTypeRep -> Bool
isFunction :: SomeTypeRep -> Bool
isFunction SomeTypeRep
d =
  case SomeTypeRep
d of
    SomeTypeRep (Fun TypeRep arg
_ TypeRep res
_) -> Bool
True
    SomeTypeRep
_other -> Bool
False

-- | Show the full type of a typeable value
showFullValueType :: Typeable a => a -> Text
showFullValueType :: forall a. Typeable a => a -> Text
showFullValueType = TypeRep a -> Text
forall arg. TypeRep arg -> Text
showTheFullValueType (TypeRep a -> Text) -> (a -> TypeRep a) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
Reflection.typeOf

-- | Show the full type of a typeable function
showFullFunctionType :: Typeable a => a -> ([Text], Text)
showFullFunctionType :: forall a. Typeable a => a -> ([Text], Text)
showFullFunctionType = TypeRep a -> ([Text], Text)
forall arg. TypeRep arg -> ([Text], Text)
showTheFullFunctionType (TypeRep a -> ([Text], Text))
-> (a -> TypeRep a) -> a -> ([Text], Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
Reflection.typeOf

-- | Show the full type of a typeable value
--   where nested types like @IO[Int]@ or functions are represented and
--   non GHC types are shown with their module names
showTheFullValueType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1). (TypeRep arg -> Text)
showTheFullValueType :: forall arg. TypeRep arg -> Text
showTheFullValueType TypeRep arg
a =
  case TypeRep arg
a of
    Fun (App TypeRep a
t1 TypeRep b
t2) TypeRep res
t3 ->
      SomeTypeRep -> SomeTypeRep -> Text
showNested (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
t1) (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
t2) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep res -> Text
forall arg. TypeRep arg -> Text
showTheFullValueType TypeRep res
t3
    Fun TypeRep arg
t1 TypeRep res
t2 ->
      TypeRep arg -> Text
forall arg. TypeRep arg -> Text
showTheFullValueType TypeRep arg
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep res -> Text
forall arg. TypeRep arg -> Text
showTheFullValueType TypeRep res
t2
    App TypeRep a
t1 TypeRep b
t2 ->
      SomeTypeRep -> SomeTypeRep -> Text
showNested (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
t1) (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
t2)
    TypeRep arg
_other ->
      SomeTypeRep -> Text
showSingleType (TypeRep arg -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep arg
a)

-- | Show the full type of a typeable value
--   where nested types like IO[Int] or functions are represented and
--   non GHC types are shown with their module names
showTheFullFunctionType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1). (TypeRep arg -> ([Text], Text))
showTheFullFunctionType :: forall arg. TypeRep arg -> ([Text], Text)
showTheFullFunctionType TypeRep arg
a =
  case TypeRep arg
a of
    Fun (App TypeRep a
t1 TypeRep b
t2) TypeRep res
t3 ->
      let ([Text]
ins, Text
out) = TypeRep res -> ([Text], Text)
forall arg. TypeRep arg -> ([Text], Text)
showTheFullFunctionType TypeRep res
t3
       in (SomeTypeRep -> SomeTypeRep -> Text
showNested (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
t1) (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
t2) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ins, Text
out)
    Fun TypeRep arg
t1 TypeRep res
t2 ->
      let in1 :: Text
in1 = TypeRep arg -> Text
forall arg. TypeRep arg -> Text
showTheFullValueType TypeRep arg
t1
          ([Text]
ins, Text
out) = TypeRep res -> ([Text], Text)
forall arg. TypeRep arg -> ([Text], Text)
showTheFullFunctionType TypeRep res
t2
       in (Text
in1 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ins, Text
out)
    App TypeRep a
t1 TypeRep b
t2 ->
      ([], SomeTypeRep -> SomeTypeRep -> Text
showNested (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
t1) (TypeRep b -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep b
t2))
    TypeRep arg
_other ->
      ([], SomeTypeRep -> Text
showSingleType (TypeRep arg -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep arg
a))

-- | Show a type like @m a@
showNested :: SomeTypeRep -> SomeTypeRep -> Text
showNested :: SomeTypeRep -> SomeTypeRep -> Text
showNested SomeTypeRep
a SomeTypeRep
b =
  Text -> Text
parenthesizeNested (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
tweakNested (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> Text
showSingleType SomeTypeRep
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
showSingleType SomeTypeRep
b

-- | Show a single type. Don't display the module for GHC types
showSingleType :: SomeTypeRep -> Text
showSingleType :: SomeTypeRep -> Text
showSingleType SomeTypeRep
a =
  case SomeTypeRep -> (TyCon, [SomeTypeRep])
splitTyConApp SomeTypeRep
a of
    (TyCon
con, []) -> TyCon -> Text
showType TyCon
con
    (TyCon
con, [SomeTypeRep
arg]) -> TyCon -> Text
showType TyCon
con Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
showSingleType SomeTypeRep
arg
    (TyCon
con, [SomeTypeRep]
args) -> TyCon -> Text
showType TyCon
con Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a b. (Show a, StringConv String b) => a -> b
show ((SomeTypeRep -> Text) -> [SomeTypeRep] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeTypeRep -> Text
showSingleType [SomeTypeRep]
args)
  where
    showType :: TyCon -> Text
showType TyCon
x =
      let typeWithModuleName :: Text
typeWithModuleName = TyCon -> Text
showWithModuleName TyCon
x
       in if Text -> Bool
mustShowModuleName Text
typeWithModuleName then Text
typeWithModuleName else TyCon -> Text
forall a b. (Show a, StringConv String b) => a -> b
show TyCon
x

-- | Return true if the module name can be shown
mustShowModuleName :: Text -> Bool
mustShowModuleName :: Text -> Bool
mustShowModuleName Text
name =
  Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
P.any Bool -> Bool
forall a. a -> a
identity ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
      (Text -> Bool) -> [Text] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Text -> Text -> Bool
`isPrefixOf` Text
name)
        [ Text
"GHC.Types.", -- for Int, Double,..
          Text
"GHC.Base.", -- for other Base types
          Text
"GHC.Maybe.", -- for Maybe
          Text
"Data.Either.", -- for Either
          Text
"Data.Text.Internal"
        ]

-- | Tweak some standard module names for better display
tweakNested :: Text -> Text
tweakNested :: Text -> Text
tweakNested Text
"List Char" = Text
"String"
tweakNested Text
n =
  if Text
"List " Text -> Text -> Bool
`isPrefixOf` Text
n
    then Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
5 Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]" -- special processing for lists
    else Text
n

-- | This is an attempt to better render "nested" types like IO (Maybe Text)
--   The input value is @"IO Maybe Text"@ and the output text will be @"IO (Maybe Text)"@
--   This will unfortunately not work with types having several type parameters
--   like @IO (Either Text Int)@
parenthesizeNested :: Text -> Text
parenthesizeNested :: Text -> Text
parenthesizeNested Text
t =
  case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
" " Text
t of
    [] -> Text
t
    [Text
_head] -> Text
t
    [Text
outer, Text
inner] -> Text
outer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inner
    Text
outer : [Text]
rest -> Text
outer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parenthesizeNested (Text -> [Text] -> Text
T.intercalate Text
" " [Text]
rest) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Show a type constructor with its module name
showWithModuleName :: TyCon -> Text
showWithModuleName :: TyCon -> Text
showWithModuleName TyCon
t = String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConModule TyCon
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TyCon -> String
tyConName TyCon
t