I really learned a lot from writing the below code, and thought I'd share it with the group. I'm slightly at a loss for words, having just spent the last two hours on this when I most certainly should have been doing other work, but these are two hours I won't regret. I'm very interested in hearing others' thoughts on "this", where "this" is "whatever comes to mind". Regards, Matt {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module TT where import Data.Tree import Data.Typeable (Typeable(..),TypeRep(..),TyCon(..) ,typeRepTyCon,typeRepArgs,tyConString) import Language.Haskell.TH(Type(..),mkName) -------------------------------------------------------- class ToType a where toType :: a -> Type class ToTree a b where toTree :: a -> Tree b {- Typeable a | typeOf | (0) | v toType TypeRep - - - - - - - - > Type | (4) | toTree | (1) (2) | toTree | | v (3) v Tree TyCon ---------------> Tree Type toTree -} -- (0) typeableToTypeRep :: (Typeable a) => a -> TypeRep typeableToTypeRep = typeOf -- (1) instance ToTree TypeRep TyCon where toTree ty = Node (typeRepTyCon ty) (fmap toTree . typeRepArgs $ ty) -- (2) instance ToTree Type Type where toTree (AppT t1 t2) = let (Node x xs) = toTree t1 in Node x (xs ++ [toTree t2]) toTree t = Node t [] -- (3.a) instance ToType TyCon where toType tyC = let tyS = tyConString tyC in case tyS of "->" -> ArrowT "[]" -> ListT "()" -> TupleT 0 ('(':',':rest) -> let n = length (takeWhile (==',') rest) in TupleT (n+2) _ -> ConT . mkName $ tyS -- (3.b) instance ToType (Tree TyCon) where toType (Node x xs) = foldl AppT (toType x) (fmap toType xs) -- (3) instance ToTree (Tree TyCon) Type where toTree = toTree . toType -- (4) instance ToType TypeRep where toType = toType . (toTree::TypeRep->Tree TyCon) -- (0) typeOf -- (1) toTree -- (2) toTree -- (3) toTree -- (4) toType -- (0) -> (1) tyConTree :: (Typeable a) => a -> Tree TyCon tyConTree = toTree . typeOf -- (0) -> (1) -> (3) typeTree_a :: (Typeable a) => a -> Tree Type typeTree_a = (toTree::Tree TyCon->Tree Type) . (toTree::TypeRep->Tree TyCon) . typeOf -- (0) -> (4) -> (2) typeTree_b :: (Typeable a) => a -> Tree Type typeTree_b = (toTree::Type->Tree Type) . (toType::TypeRep->Type) . typeOf diagram_commutes :: (Typeable a) => a -> Bool diagram_commutes a = typeTree_a a == typeTree_b a -- ghci> diagram_commutes x0 -- True x0 :: (Num a) => ((a,(a,((a,a),a))),(a,(a,a))) x0 = ((0,(0,((0,0),0))),(0,(0,0))) -------------------------------------------------------- printTree :: (Show a) => Tree a -> IO () printTree = putStr . drawTree . fmap show printForest :: (Show a) => Forest a -> IO () printForest = putStr . drawForest . (fmap . fmap) show -------------------------------------------------------- {- ghci> printTree $ tyConTree x0 (,) | +- (,) | | | +- Integer | | | `- (,) | | | +- Integer | | | `- (,) | | | +- (,) | | | | | +- Integer | | | | | `- Integer | | | `- Integer | `- (,) | +- Integer | `- (,) | +- Integer | `- Integer ghci> printTree $ typeTree_a x0 TupleT 2 | +- TupleT 2 | | | +- ConT Integer | | | `- TupleT 2 | | | +- ConT Integer | | | `- TupleT 2 | | | +- TupleT 2 | | | | | +- ConT Integer | | | | | `- ConT Integer | | | `- ConT Integer | `- TupleT 2 | +- ConT Integer | `- TupleT 2 | +- ConT Integer | `- ConT Integer ghci> printTree $ typeTree_b x0 TupleT 2 | +- TupleT 2 | | | +- ConT Integer | | | `- TupleT 2 | | | +- ConT Integer | | | `- TupleT 2 | | | +- TupleT 2 | | | | | +- ConT Integer | | | | | `- ConT Integer | | | `- ConT Integer | `- TupleT 2 | +- ConT Integer | `- TupleT 2 | +- ConT Integer | `- ConT Integer -} --------------------------------------------------------