{-# 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 "AdaptList", text type_x, text "where"])
    4
    (vcat [
        hsep [ text "data"
             ,      text "List"
             ,      text type_x
             , char '='
             ,      text myemptyconstr
             , char '|'
             ,      text myconsconstr
             ,      text "{-# UNPACK #-}!" <> text type_x
             ,      parens (text "List" <+> text type_x)
             ]

       ,hsep [  text "empty"
             ,char '='
             ,  text myemptyconstr]

       ,hsep [  text "cons"
             ,char '='
             ,  text myconsconstr]

       ,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 '_')
             ,char '='
             ,  char 'x']

       ,hsep [  text "tail"
             ,  text myemptyconstr
             ,char '='
             ,  text "errorEmptyList \"tail\""
             ]
       ,hsep [  text "tail"
             ,  parens (text myconsconstr <+> char '_' <+> char 'x')
             ,char '='
             ,  char 'x']


        ])


 where
    type_x = inst_a

    myemptyconstr = "Empty" ++ type_x
    myconsconstr = "Cons" ++ 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']