{-# 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)
{-
-- Monomorphic, but we have to flatten ourselves. GHC is doing something wrong.
instance AdaptList (Pair Int Int) where
data List (Pair Int Int)
= EmptyPairIntInt
| ConsPairIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int (List (Pair Int Int))
empty = EmptyPairIntInt
cons x xs = ConsPairIntInt (fst x) (snd x) xs
null EmptyPairIntInt = True
null _ = False
head EmptyPairIntInt = errorEmptyList "head"
head (ConsPairIntInt x y _) = pair x y
tail EmptyPairIntInt = errorEmptyList "tail"
tail (ConsPairIntInt _ _ xs) = xs
-}
derive :: (Typeable a, Data a, Typeable b, Data b) => a -> b -> String
derive x y = render $
hang
(hsep [text "instance", text "AdaptList",
parens (text "Pair" <+> text type_x <+> text type_y), text "where"])
4
(vcat [
-- data List (Pair Int Int)
-- = EmptyPairIntInt
-- | ConsPairIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int (List (Pair Int Int))
hsep [ text "data"
, text "List"
, parens (hsep [text "Pair"
, text type_x
, text type_y
])
],
(hang empty 4
(vcat [ hsep [ char '=', text myemptyconstr]
, hsep [ char '|'
, text myconsconstr
, text "{-# UNPACK #-}!" <> text type_x
, text "{-# UNPACK #-}!" <> text type_y
, parens (text "List" <+>
parens (text "Pair" <+> text type_x <+> text type_y))
]
]))
,hsep [ text "empty"
,char '='
, text myemptyconstr]
-- cons x xs = ConsPairIntInt (fst x) (snd x) xs
,hsep [ text "cons"
, char 'x'
, char 'z'
,char '='
, text myconsconstr
, parens (text "fst" <+> char 'x')
, parens (text "snd" <+> char 'x')
, char 'z'
]
,hsep [ text "null"
, text myemptyconstr
,char '='
, text "True"]
,hsep [ text "null"
, char '_'
,char '='
, text "False"]
,hsep [ text "head"
, text myemptyconstr
,char '='
, text "errorEmptyList \"head\""
]
,hsep [ text "head"
, parens (text myconsconstr <+> char 'x' <+> char 'y' <+> char '_')
,char '='
, text "pair" <+> char 'x' <+> char 'y']
,hsep [ text "tail"
, text myemptyconstr
,char '='
, text "errorEmptyList \"tail\""
]
,hsep [ text "tail"
, parens (text myconsconstr <+> char '_' <+> char '_' <+> char 'x')
,char '='
, char 'x']
])
{-
-}
where
type_x = inst_a
type_y = inst_b
myemptyconstr = "EmptyPair" ++ type_x ++ type_y
myconsconstr = "ConsPair" ++ 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']