-- | Homogeneous tuples as newtypes of standard Haskell tuples.
-- This is a third alternative implementation.
--
-- > ntup3 1 2 3 == NTup3 (1,2,3)
--

{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving #-}
module Data.Tup.Newtype where

--------------------------------------------------------------------------------

import Control.Applicative

import Data.List
import Data.Foldable
import Data.Traversable
import Data.Monoid

import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal

import Data.Tup.Class

--------------------------------------------------------------------------------
-- * newtyped tuples

data    NTup0 a = NTup0                     deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup1 a = NTup1  a                  deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup2 a = NTup2 (a,a)               deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup3 a = NTup3 (a,a,a)             deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup4 a = NTup4 (a,a,a,a)           deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup5 a = NTup5 (a,a,a,a,a)         deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup6 a = NTup6 (a,a,a,a,a,a)       deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup7 a = NTup7 (a,a,a,a,a,a,a)     deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup8 a = NTup8 (a,a,a,a,a,a,a,a)   deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)
newtype NTup9 a = NTup9 (a,a,a,a,a,a,a,a,a) deriving (Eq,Ord,Read,Show,Bounded,Functor,Foldable,Traversable)

--------------------------------------------------------------------------------
-- * constructing NTups

ntup0 :: NTup0 a
ntup0 = NTup0

ntup1 :: a -> NTup1 a
ntup1 x1 = NTup1 x1

ntup2 :: a -> a -> NTup2 a
ntup2 x1 x2 = NTup2 (x1,x2)

ntup3 :: a -> a -> a -> NTup3 a
ntup3 x1 x2 x3 = NTup3 (x1,x2,x3)

ntup4 :: a -> a -> a -> a -> NTup4 a
ntup4 x1 x2 x3 x4 = NTup4 (x1,x2,x3,x4)

ntup5 :: a -> a -> a -> a -> a -> NTup5 a
ntup5 x1 x2 x3 x4 x5 = NTup5 (x1,x2,x3,x4,x5)

ntup6 :: a -> a -> a -> a -> a -> a -> NTup6 a
ntup6 x1 x2 x3 x4 x5 x6 = NTup6 (x1,x2,x3,x4,x5,x6)

ntup7 :: a -> a -> a -> a -> a -> a -> a -> NTup7 a
ntup7 x1 x2 x3 x4 x5 x6 x7 = NTup7 (x1,x2,x3,x4,x5,x6,x7)

ntup8 :: a -> a -> a -> a -> a -> a -> a -> a -> NTup8 a
ntup8 x1 x2 x3 x4 x5 x6 x7 x8 = NTup8 (x1,x2,x3,x4,x5,x6,x7,x8)

ntup9 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> NTup9 a
ntup9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = NTup9 (x1,x2,x3,x4,x5,x6,x7,x8,x9)

--------------------------------------------------------------------------------
-- * deconstructing NTups

untup1 :: NTup1 a -> a
untup1 (NTup1 t) = t

untup2 :: NTup2 a -> (a,a)
untup2 (NTup2 t) = t

untup3 :: NTup3 a -> (a,a,a)
untup3 (NTup3 t) = t

untup4 :: NTup4 a -> (a,a,a,a)
untup4 (NTup4 t) = t

untup5 :: NTup5 a -> (a,a,a,a,a)
untup5 (NTup5 t) = t

untup6 :: NTup6 a -> (a,a,a,a,a,a)
untup6 (NTup6 t) = t

untup7 :: NTup7 a -> (a,a,a,a,a,a,a)
untup7 (NTup7 t) = t

untup8 :: NTup8 a -> (a,a,a,a,a,a,a,a)
untup8 (NTup8 t) = t

untup9 :: NTup9 a -> (a,a,a,a,a,a,a,a,a)
untup9 (NTup9 t) = t

--------------------------------------------------------------------------------

instance Tup NTup0 where
  tupSize   _    = 0
  tupToList _    = []
  tupFromList [] = NTup0
  tupFromList _  = error "tupFromList: list should have length 0"

instance Tup NTup1 where
  tupSize _ = 1
  tupToList (NTup1 x1) = [x1]
  tupFromList [x1] = NTup1 x1
  tupFromList _ = error "tupFromList: list should have length 1"

instance Tup NTup2 where
  tupSize _ = 2
  tupToList (NTup2 (x1,x2)) = [x1,x2]
  tupFromList [x1,x2] = NTup2 (x1,x2)
  tupFromList _ = error "tupFromList: list should have length 2"

instance Tup NTup3 where
  tupSize _ = 3
  tupToList (NTup3 (x1,x2,x3)) = [x1,x2,x3]
  tupFromList [x1,x2,x3] = NTup3 (x1,x2,x3)
  tupFromList _ = error "tupFromList: list should have length 3"

instance Tup NTup4 where
  tupSize _ = 4
  tupToList (NTup4 (x1,x2,x3,x4)) = [x1,x2,x3,x4]
  tupFromList [x1,x2,x3,x4] = NTup4 (x1,x2,x3,x4)
  tupFromList _ = error "tupFromList: list should have length 4"

instance Tup NTup5 where
  tupSize _ = 5
  tupToList (NTup5 (x1,x2,x3,x4,x5)) = [x1,x2,x3,x4,x5]
  tupFromList [x1,x2,x3,x4,x5] = NTup5 (x1,x2,x3,x4,x5)
  tupFromList _ = error "tupFromList: list should have length 5"

instance Tup NTup6 where
  tupSize _ = 6
  tupToList (NTup6 (x1,x2,x3,x4,x5,x6)) = [x1,x2,x3,x4,x5,x6]
  tupFromList [x1,x2,x3,x4,x5,x6] = NTup6 (x1,x2,x3,x4,x5,x6)
  tupFromList _ = error "tupFromList: list should have length 6"

instance Tup NTup7 where
  tupSize _ = 7
  tupToList (NTup7 (x1,x2,x3,x4,x5,x6,x7)) = [x1,x2,x3,x4,x5,x6,x7]
  tupFromList [x1,x2,x3,x4,x5,x6,x7] = NTup7 (x1,x2,x3,x4,x5,x6,x7)
  tupFromList _ = error "tupFromList: list should have length 7"

instance Tup NTup8 where
  tupSize _ = 8
  tupToList (NTup8 (x1,x2,x3,x4,x5,x6,x7,x8)) = [x1,x2,x3,x4,x5,x6,x7,x8]
  tupFromList [x1,x2,x3,x4,x5,x6,x7,x8] = NTup8 (x1,x2,x3,x4,x5,x6,x7,x8)
  tupFromList _ = error "tupFromList: list should have length 8"

instance Tup NTup9 where
  tupSize _ = 9
  tupToList (NTup9 (x1,x2,x3,x4,x5,x6,x7,x8,x9)) = [x1,x2,x3,x4,x5,x6,x7,x8,x9]
  tupFromList [x1,x2,x3,x4,x5,x6,x7,x8,x9] = NTup9 (x1,x2,x3,x4,x5,x6,x7,x8,x9)
  tupFromList _ = error "tupFromList: list should have length 9"

--------------------------------------------------------------------------------

instance Applicative NTup0 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure _ = NTup0
  NTup0 <*> NTup0 = NTup0

instance Applicative NTup1 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup1 x
  NTup1 f1 <*> NTup1 x1 = NTup1 (f1 x1)

instance Applicative NTup2 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup2 (x,x)
  NTup2 (f1,f2) <*> NTup2 (x1,x2) = NTup2 (f1 x1, f2 x2)

instance Applicative NTup3 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup3 (x,x,x)
  NTup3 (f1,f2,f3) <*> NTup3 (x1,x2,x3) = NTup3 (f1 x1, f2 x2, f3 x3)

instance Applicative NTup4 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup4 (x,x,x,x)
  NTup4 (f1,f2,f3,f4) <*> NTup4 (x1,x2,x3,x4) = NTup4 (f1 x1, f2 x2, f3 x3, f4 x4)

instance Applicative NTup5 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup5 (x,x,x,x,x)
  NTup5 (f1,f2,f3,f4,f5) <*> NTup5 (x1,x2,x3,x4,x5) = NTup5 (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5)

instance Applicative NTup6 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup6 (x,x,x,x,x,x)
  NTup6 (f1,f2,f3,f4,f5,f6) <*> NTup6 (x1,x2,x3,x4,x5,x6) = NTup6 (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5, f6 x6)

instance Applicative NTup7 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup7 (x,x,x,x,x,x,x)
  NTup7 (f1,f2,f3,f4,f5,f6,f7) <*> NTup7 (x1,x2,x3,x4,x5,x6,x7) 
    = NTup7 (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5, f6 x6, f7 x7)

instance Applicative NTup8 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup8 (x,x,x,x,x,x,x,x)
  NTup8 (f1,f2,f3,f4,f5,f6,f7,f8) <*> NTup8 (x1,x2,x3,x4,x5,x6,x7,x8)
    = NTup8 (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5, f6 x6, f7 x7, f8 x8)

instance Applicative NTup9 where
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}
  pure x = NTup9 (x,x,x,x,x,x,x,x,x)
  NTup9 (f1,f2,f3,f4,f5,f6,f7,f8,f9) <*> NTup9 (x1,x2,x3,x4,x5,x6,x7,x8,x9)
    = NTup9 (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5, f6 x6, f7 x7, f8 x8, f9 x9)

--------------------------------------------------------------------------------

#define NUM_INSTANCE                   \
  { t1 + t2 = (+) <$> t1 <*> t2        \
  ; t1 - t2 = (-) <$> t1 <*> t2        \
  ; t1 * t2 = (*) <$> t1 <*> t2        \
  ; abs    = fmap abs                  \
  ; signum = fmap signum               \
  ; fromInteger = pure . fromInteger }

instance Num a => Num (NTup0 a) where NUM_INSTANCE
instance Num a => Num (NTup1 a) where NUM_INSTANCE
instance Num a => Num (NTup2 a) where NUM_INSTANCE
instance Num a => Num (NTup3 a) where NUM_INSTANCE
instance Num a => Num (NTup4 a) where NUM_INSTANCE
instance Num a => Num (NTup5 a) where NUM_INSTANCE
instance Num a => Num (NTup6 a) where NUM_INSTANCE
instance Num a => Num (NTup7 a) where NUM_INSTANCE
instance Num a => Num (NTup8 a) where NUM_INSTANCE
instance Num a => Num (NTup9 a) where NUM_INSTANCE

--------------------------------------------------------------------------------

#define FRACTIONAL_INSTANCE              \
  { t1 / t2 = (/) <$> t1 <*> t2          \
  ; recip   = fmap recip                 \
  ; fromRational = pure . fromRational }

instance Fractional a => Fractional (NTup0 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup1 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup2 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup3 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup4 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup5 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup6 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup7 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup8 a) where FRACTIONAL_INSTANCE
instance Fractional a => Fractional (NTup9 a) where FRACTIONAL_INSTANCE

--------------------------------------------------------------------------------

#define MONOID_INSTANCE                     \
  { mempty = pure mempty                    \
  ; mappend t1 t2 = mappend <$> t1 <*> t2 } 

instance Monoid a => Monoid (NTup0 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup1 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup2 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup3 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup4 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup5 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup6 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup7 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup8 a) where MONOID_INSTANCE
instance Monoid a => Monoid (NTup9 a) where MONOID_INSTANCE

--------------------------------------------------------------------------------

#define STORABLE_INSTANCE                                 \
  { sizeOf    t = tupSize t * sizeOf (tupUndef t)         \
  ; alignment t = alignment (tupUndef t)                  \
  ; peek ptr    = let { ptrUndef :: Ptr b -> b ; ptrUndef _ = undefined }              \
                  in  tupFromList <$> peekArray (tupSize $ ptrUndef ptr) (castPtr ptr) \
  ; poke ptr t  = pokeArray (castPtr ptr) (tupToList t) }

instance Storable a => Storable (NTup0 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup1 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup2 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup3 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup4 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup5 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup6 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup7 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup8 a) where STORABLE_INSTANCE
instance Storable a => Storable (NTup9 a) where STORABLE_INSTANCE

--------------------------------------------------------------------------------