RuntimeTypes.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ViewPatterns #-}
module RuntimeTypes where

import Data.Kind
import Data.Proxy
import Data.Typeable
import Unsafe.Coerce

instance Eq Type where
  x == y = fromType x == fromType y

instance Ord Type where
  compare x y = compare (fromType x) (fromType y)

instance Show Type where
  show = show . fromType

toType :: TypeRep -> Type
toType = unsafeCoerce

fromType :: Type -> TypeRep
fromType = unsafeCoerce

theType :: forall t . Typeable t => Type
theType = toType (theTypeRep @t)

theTypeRep :: forall t . Typeable t => TypeRep
theTypeRep = typeRep (Proxy :: Proxy t)

splits :: forall c . Typeable c => Type -> Maybe [Type]
splits t = case splitTyConApp (fromType t) of
    (tc, as) | tc == typeRepTyCon (theTypeRep @c) -> Just (map toType as)
    _ -> Nothing


pattern TInt :: Type
pattern TInt <- ((theType @Int ==) -> True) where
  TInt = theType @Int

pattern TType :: Type
pattern TType <- ((theType @Type ==) -> True) where
  TType = theType @Type

pattern TList :: Type -> Type
pattern TList t <- (splits @[] -> Just [t]) where
  TList t = toType (mkAppTy (theTypeRep @[]) (fromType t))

pattern TFun :: Type -> Type -> Type
pattern TFun t1 t2 <- (splits @(->) -> Just [t1, t2]) where
  TFun t1 t2 = toType (mkFunTy (fromType t1) (fromType t2))


ts :: [Type]
ts = [theType @[Int], theType @(Int -> Bool), theType @(Int, Int)]

f :: Type -> Bool
f (TFun TInt _) = True
f _             = False

x = map f ts

describe :: Type -> String
describe TInt         = "integers"
describe TType        = "types"
describe (TList t)    = "lists of " ++ describe t
describe (TFun t1 t2) = "functions from " ++ describe t1 ++ " to " ++ describe t2
describe t = show t

y = describe (theType @(Int -> [Type]))