{-# 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 | Box t <- 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 . (Typeable a, Data a) => a -> IO ()
deriveM (a :: a) = putStrLn $ derive (undefined :: a)
{-
instance AdaptList Int where
data List Int = EmptyInt | ConsInt {-# UNPACK #-}!Int (List Int)
empty = EmptyInt
cons x xs = ConsInt x xs
null EmptyInt = True
null _ = False
head EmptyInt = errorEmptyList "head"
head (ConsInt x _) = x
tail EmptyInt = errorEmptyList "tail"
tail (ConsInt _ xs) = xs
-}
derive :: (Typeable a, Data a) => a -> String
derive x = render $
hang
(hsep [text "instance", text "AdaptMaybe", text type_x, text "where"])
4
(vcat [
hsep [ text "data"
, text "Maybe"
, text type_x
, char '='
, text myNothingConstr
, char '|'
, text myJustConstr
, text "{-# UNPACK #-}!" <> text type_x
]
{-
maybe n _ NothingInt = n
maybe _ f (JustInt x) = f x
-}
,hsep [ text "just"
,char '='
, text myJustConstr]
,hsep [ text "nothing"
,char '='
, text myNothingConstr]
,hsep [ text "isJust"
, parens (text myJustConstr <+> char '_' )
,char '='
, text "True"]
,hsep [ text "isJust"
, char '_'
,char '='
, text "False"]
,hsep [ text "maybe"
, char 'n'
, char '_'
, text myNothingConstr
,char '='
, char 'n'
]
,hsep [ text "maybe"
, char '_'
, char 'f'
, parens (text myJustConstr <+> char 'x')
,char '='
, char 'f'
, char 'x']
])
where
type_x = inst_a
myNothingConstr = "Nothing" ++ type_x
myJustConstr = "Just" ++ type_x
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
manyLetters = map (:[]) ['a'..'z']