{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeInType #-}
module Data.Registry.Internal.Reflection where
import Data.Semigroup
import Data.Text as T
import Data.Typeable (tyConModule, tyConName, splitTyConApp)
import Protolude as P hiding (intercalate, TypeRep, isPrefixOf, (<>))
import Type.Reflection
import GHC.Exts
isFunction :: SomeTypeRep -> Bool
isFunction d =
case d of
SomeTypeRep (Fun _ _) -> True
_ -> False
showFullValueType :: Typeable a => a -> Text
showFullValueType = showTheFullValueType . typeOf
showFullFunctionType :: Typeable a => a -> ([Text], Text)
showFullFunctionType = showTheFullFunctionType . typeOf
showTheFullValueType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> Text)
showTheFullValueType a =
case a of
Fun t1 t2 ->
showTheFullValueType t1 <> " -> " <> showTheFullValueType t2
Fun (App t1 t2) t3 ->
showNested (SomeTypeRep t1) (SomeTypeRep t2) <> " -> " <> showTheFullValueType t3
App t1 t2 ->
showNested (SomeTypeRep t1) (SomeTypeRep t2)
_ ->
showSingleType (SomeTypeRep a)
showTheFullFunctionType :: forall (r1 :: RuntimeRep) (arg :: TYPE r1) . (TypeRep arg -> ([Text], Text))
showTheFullFunctionType a =
case a of
Fun t1 t2 ->
let in1 = showTheFullValueType t1
(ins, out) = showTheFullFunctionType t2
in (in1 : ins, out)
Fun (App t1 t2) t3 ->
let (ins, out) = showTheFullFunctionType t3
in (showNested (SomeTypeRep t1) (SomeTypeRep t2) : ins, out)
App t1 t2 ->
([], showNested (SomeTypeRep t1) (SomeTypeRep t2))
_ ->
([], showSingleType (SomeTypeRep a))
showNested :: SomeTypeRep -> SomeTypeRep -> Text
showNested a b =
parenthesizeNested $ tweakNested $ showSingleType a <> " " <> showSingleType b
showSingleType :: SomeTypeRep -> Text
showSingleType a =
case splitTyConApp a of
(con, []) -> showType con
(con, [arg]) -> showType con <> " " <> showSingleType arg
(con, args) -> showType con <> " " <> show (fmap showSingleType args)
where showType x =
let typeWithModuleName = showWithModuleName x
in if mustShowModuleName typeWithModuleName then typeWithModuleName else show x
mustShowModuleName :: Text -> Bool
mustShowModuleName name = not $ P.any identity $
fmap (`isPrefixOf` name) [
"GHC.Types."
, "GHC.Base."
, "GHC.Maybe."
, "Data.Either."
, "Data.Text.Internal"]
tweakNested :: Text -> Text
tweakNested "[] Char" = "String"
tweakNested n =
if "[] " `isPrefixOf` n then
"[" <> T.drop 3 n <> "]"
else
n
parenthesizeNested :: Text -> Text
parenthesizeNested t =
case T.splitOn " " t of
[] -> t
[_] -> t
[outer, inner] -> outer <> " " <> inner
outer : rest -> outer <> " (" <> parenthesizeNested (T.intercalate " " rest) <> ")"
showWithModuleName :: TyCon -> Text
showWithModuleName t = toS $ tyConModule t <> "." <> tyConName t