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