{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE TypeInType          #-}

{- |
  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)
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import           Protolude       as P hiding (intercalate, TypeRep, isPrefixOf, (<>), typeOf)
#else
import           Protolude       as P hiding (intercalate, TypeRep, isPrefixOf, (<>))
#endif
import           Type.Reflection as Reflection
import           GHC.Exts

-- | 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 :: 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 :: 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 :: 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 :: 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, ConvertText String b) => a -> b
show ((SomeTypeRep -> Text) -> [SomeTypeRep] -> [Text]
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, ConvertText 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 (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
"[] Char" = Text
"String"
tweakNested Text
n =
  if Text
"[] " Text -> Text -> Bool
`isPrefixOf` Text
n then
    Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
3 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 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