\begin{code}

{- Mostly based on Scrap Your Boilerplate -}

import GHC.Prim (unsafeCoerce#)
import Maybe (fromJust,fromMaybe)
import List (intersperse)
import Monad (msum)

type TypeName = String
data Type = Type TypeName [Type] deriving Eq

instance Show Type where
    showsPrec p t@(Type "->" [x,y])
        | p == 0 = showsPrec 1 x . (" -> "++) . showsPrec 0 y
        | otherwise = ('(':) . showsPrec 0 t . (')':) 
    showsPrec _ (Type "[]" [x]) = ('[':) . shows x . (']':)
    showsPrec _ (Type ('(':xs) ys) 
        = ('(':) 
        . (foldr (.) id $ intersperse (',':) $ map shows ys)
        . (')':)
    showsPrec _ (Type name []) = (name++)
    showsPrec p t@(Type name xs) 
        | p == 0 = (name++) 
                 . (foldr (.) id $ map (\s -> (' ':) . showsPrec 1 s) xs)
        | otherwise = ('(':) . showsPrec 0 t . (')':)

class Typeable a where
    typeOf :: a -> Type

data Dynamic = forall a. Dynamic Type a

cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r where 
    r = if typeOf (fromJust r) == typeOf x 
        then Just (unsafeCoerce# x)
        else Nothing

toDyn :: Typeable a => a -> Dynamic
toDyn x = Dynamic (typeOf x) x

fromDyn :: Typeable a => Dynamic -> Maybe a
fromDyn (Dynamic t x) = r where
    r = if typeOf (fromJust r) == t
        then Just (unsafeCoerce# x)
        else Nothing

fromDyn' :: Typeable a => Dynamic -> a
fromDyn' d@(Dynamic t x) = case fromDyn d of
    Just r -> r
    r@Nothing -> error $ "fromDyn': Expected a " 
                       ++ show (typeOf $ fromJust r) ++ ", got a "
                       ++ show t

dynType :: Dynamic -> Type
dynType (Dynamic t _) = t

applyDyn :: Dynamic -> Dynamic -> Maybe Dynamic
applyDyn (Dynamic (Type "->" [tyArg,tyRet]) f) (Dynamic tyArg' arg)
    | tyArg == tyArg' = Just $ Dynamic tyRet $ unsafeCoerce# f $ arg
    | otherwise = Nothing
applyDyn _ _ = Nothing
\end{code}

\begin{code}
#define STRINGIFY(name) "name"

{- FIXME: This doesn't scale well... sounds like Template Haskell time -}
#define TYPE_INSTANCE0(name) \
instance Typeable name where typeOf _ = Type STRINGIFY(name) []

#define TYPE_INSTANCE1(name) \
instance Typeable a => Typeable (name a) where { \
    typeOf x = Type STRINGIFY(name) [typeOf (arg1 x)] where { \
        arg1 :: name a -> a; arg1 = undefined \
    } \
}

#define TYPE_INSTANCE2(name) \
instance (Typeable a, Typeable b) => Typeable (name a b) where { \
    typeOf x = Type STRINGIFY(name) [typeOf (arg1 x), typeOf (arg2 x)] where { \
        arg1 :: name a b -> a; arg1 = undefined; \
        arg2 :: name a b -> b; arg2 = undefined; \
    } \
}

#define TYPE_INSTANCE3(name) \
instance (Typeable a, Typeable b, Typeable c) => Typeable (name a b c) where { \
    typeOf x = Type STRINGIFY(name) [typeOf (arg1 x), typeOf (arg2 x), typeOf (arg3 x)] where { \
        arg1 :: name a b c -> a; arg1 = undefined; \
        arg2 :: name a b c -> b; arg2 = undefined; \
        arg3 :: name a b c -> c; arg3 = undefined; \
    } \
}

instance (Typeable a, Typeable b) => Typeable (a -> b) where
    typeOf x = Type "->" [typeOf (arg x), typeOf (ret x)] where
        arg :: (a -> b) -> a; arg = undefined
        ret :: (a -> b) -> b; ret = undefined

TYPE_INSTANCE0(Int)
TYPE_INSTANCE0(Integer)
TYPE_INSTANCE0(Bool)
TYPE_INSTANCE0(Char)
TYPE_INSTANCE1([])
TYPE_INSTANCE1(Maybe)
TYPE_INSTANCE2(Either)
TYPE_INSTANCE2((,))
TYPE_INSTANCE3((,,))

test :: [Dynamic]
test = [toDyn (10::Int), toDyn (1234567890::Integer), toDyn "Foo", 
        toDyn True, toDyn 'x', toDyn (Just 10::Maybe Int),
        toDyn (Just $ Left $ "LeftEither" :: Maybe (Either String (Maybe Int))),
        toDyn ('c',False,'t'), toDyn (10::Int,"Foo")]

funcs :: [Dynamic]
funcs = [toDyn (succ :: Int -> Int), toDyn (++"Done"), 
         toDyn (show :: Integer -> String)]

combos :: [Dynamic]
combos = [r | Just r <- [f `applyDyn` x | f <- funcs, x <- test]]

\end{code}