{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
module Data.TypeId where

import Data.Typeable
import System.IO.Unsafe
import Data.Ord 
import Control.Arrow
import Data.Binary
import Data.DeriveTH
import Control.Monad

newtype TypeId = T { unT :: TypeRep } deriving (Eq,Typeable)

newtype Rep = R (String, [Rep]) deriving (Read, Show)

toRep :: TypeRep -> Rep
toRep t = R (show con, map toRep args)
          where (con, args) = splitTyConApp t

fromRep :: Rep -> TypeRep
fromRep (R (con, args)) = mkTyConApp (mkTyCon con) $ map fromRep args

instance Show TypeId where
    show = show . toRep . unT

instance Read TypeId where
    readsPrec d = map (first (T . fromRep)) . readsPrec d

instance Ord TypeId where
    compare = comparing (unsafePerformIO . typeRepKey . unT)

typeIdOf :: (Typeable a) => a -> TypeId
typeIdOf x = T . Data.Typeable.typeOf $ x

$(derive makeBinary ''Rep)

instance Binary TypeId where
    put = put . toRep . unT
    get = fmap (T . fromRep) get