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
-}
--------------------------------------------------------
