{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
module Type.Show where
import Prelude
import Data.Typeable
import Data.Monoid
import GHC.TypeLits
import Control.Monad.IO.Class
import Text.Show.Pretty (ppValue, parseValue)
import Text.PrettyPrint (Doc, text)
import GHC.Exts (Constraint)
class Typeable a => TypeShow a where
showType :: String
instance {-# OVERLAPPABLE #-} Typeable a => TypeShow a where
showType = show $ typeRep (Proxy :: Proxy a) ; {-# INLINE showType #-}
printType, ppPrintType :: forall a m. (TypeShow a, MonadIO m) => m ()
printType = liftIO . putStrLn $ showType @a ; {-# INLINE printType #-}
ppPrintType = liftIO . putStrLn $ ppShowType @a ; {-# INLINE ppPrintType #-}
ppShowType :: forall a. TypeShow a => String
ppTypeDoc :: forall a. TypeShow a => Doc
ppShowType = show $ ppTypeDoc @a ; {-# INLINE ppShowType #-}
ppTypeDoc = case parseValue txt of
Just v -> ppValue v
Nothing -> text txt
where txt = showType @a
{-# INLINE ppTypeDoc #-}
instance KnownNat n => TypeShow (n :: Nat) where showType = show $ natVal (Proxy :: Proxy n)
instance (ListElemsShow a, Typeable a) => TypeShow (a :: [k]) where showType = "[" <> showListElems @a <> "]"
instance (TypeShow a, TypeShow b, Typeable '(a,b)) => TypeShow '(a,b) where showType = "(" <> showType @a <> ", " <> showType @b <> ")"
class ListElemsShow a where showListElems :: String
instance {-# OVERLAPPABLE #-} ListElemsShow '[] where showListElems = ""
instance {-# OVERLAPPABLE #-} TypeShow a => ListElemsShow '[a] where showListElems = showType @a
instance {-# OVERLAPPABLE #-} (TypeShow a, ListElemsShow as) => ListElemsShow (a ': as) where showListElems = showType @a <> ", " <> showListElems @as