{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# OPTIONS -fglasgow-exts #-}
module AdaptiveDerive where
import Data.Generics
import Data.List
import Text.PrettyPrint
import Control.Monad
import Data.Int
import Data.Word
{-
instance Adapt Int Int where
data Pair Int Int = PIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int
fst (PIntInt a _) = a
snd (PIntInt _ b) = b
curry f x y = f (PIntInt x y)
uncurry f p = f (fst p) (snd p)
-}
------------------------------------------------------------------------
main = sequence_ . intersperse (putStrLn "") $
[ deriveM t u
| Box t <- types
, Box u <- types ]
data Box = forall a. (Typeable a, Data a) => Box a
types :: [Box]
types = [ Box (undefined :: Int)
, Box (undefined :: Integer)
, Box (undefined :: Int8)
, Box (undefined :: Int16)
, Box (undefined :: Int32)
, Box (undefined :: Int64)
, Box (undefined :: Word)
, Box (undefined :: Word8)
, Box (undefined :: Word16)
, Box (undefined :: Word32)
, Box (undefined :: Word64)
, Box (undefined :: Double)
, Box (undefined :: Float)
, Box (undefined :: Char)
]
------------------------------------------------------------------------
deriveM :: forall a b . (Typeable a, Data a, Typeable b, Data b) => a -> b -> IO ()
deriveM (a :: a) (b :: b) = putStrLn $ derive (undefined :: a) (undefined :: b)
derive :: (Typeable a, Data a, Typeable b, Data b) => a -> b -> String
derive x y = render $
hang
(hsep [text "instance", text "Adapt", text type_x, text type_y, text "where"])
4
(vcat [
hsep [ text "data"
, text "Pair"
, text type_x
, text type_y
, char '='
, text myconstr
, text "{-# UNPACK #-}!" <> text type_x
, text "{-# UNPACK #-}!" <> text type_y
]
,hsep [text "fst"
, parens (text myconstr <+> text "a _")
, char '=' , char 'a' ]
,hsep [text "snd"
, parens (text myconstr <+> text "_ b")
, char '=' , char 'b' ]
,hsep [ text "curry"
, char 'f'
, char 'x'
, char 'y'
, char '='
, char 'f' <+> parens (text myconstr <+> text "x y")
]
])
where
type_x = inst_a
type_y = inst_b
myconstr = "Pair" ++ type_x ++ type_y
inst_a = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters
where (typeName,typeChildren) = splitTyConApp (typeOf x)
typeLetters = take nTypeChildren manyLetters
nTypeChildren = length typeChildren
wrap x = if nTypeChildren > 0 then "("++x++")" else x
inst_b = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters
where (typeName,typeChildren) = splitTyConApp (typeOf y)
typeLetters = take nTypeChildren manyLetters
nTypeChildren = length typeChildren
wrap x = if nTypeChildren > 0 then "("++x++")" else x
manyLetters = map (:[]) ['a'..'z']