{-# 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 "AdaptPair", 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']