[Haskell-cafe] Types and Trees

[Matt Morrow]

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

-}
--------------------------------------------------------