/* -----------------------------------------------------------------------------
 *
 * Module      :  Dirty CPP hackery for OpenGL's basic types
 * Copyright   :  (c) Sven Panne 2009 + the FFI task force
 * License     :  BSD-style (see the file LICENSE)
 * 
 * Maintainer  :  sven.panne@aedion.de
 * Stability   :  stable
 * Portability :  portable
 *
 * This header should only define preprocessor macros! It is basically a
 * slightly modified version of CTypes.h and Typeable.h from GHC's base package.
 *
 * -------------------------------------------------------------------------- */

#ifndef CTYPES_H
#define CTYPES_H

#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
tcname :: TyCon; \
tcname = mkTyCon str; \
instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }

--  // A hacked version for GHC follows the Haskell 98 version...
#ifndef __GLASGOW_HASKELL__

#define ARITHMETIC_TYPE(T,C,S,B) \
newtype T = T B deriving (Eq, Ord) ; \
INSTANCE_NUM(T) ; \
INSTANCE_REAL(T) ; \
INSTANCE_READ(T,B) ; \
INSTANCE_SHOW(T,B) ; \
INSTANCE_ENUM(T) ; \
INSTANCE_STORABLE(T) ; \
INSTANCE_TYPEABLE0(T,C,S) ;

#define INTEGRAL_TYPE(T,C,S,B) \
ARITHMETIC_TYPE(T,C,S,B) ; \
INSTANCE_BOUNDED(T) ; \
INSTANCE_INTEGRAL(T) ; \
INSTANCE_BITS(T)

#define FLOATING_TYPE(T,C,S,B) \
ARITHMETIC_TYPE(T,C,S,B) ; \
INSTANCE_FRACTIONAL(T) ; \
INSTANCE_FLOATING(T) ; \
INSTANCE_REALFRAC(T) ; \
INSTANCE_REALFLOAT(T)

#define INSTANCE_READ(T,B) \
instance Read T where { \
   readsPrec p s = map (\(x, t) -> (T x, t)) (readsPrec p s) }

#define INSTANCE_SHOW(T,B) \
instance Show T where { \
   showsPrec p (T x) = showsPrec p x }

#define INSTANCE_NUM(T) \
instance Num T where { \
   (T i) + (T j) = T (i + j) ; \
   (T i) - (T j) = T (i - j) ; \
   (T i) * (T j) = T (i * j) ; \
   negate  (T i) = T (negate i) ; \
   abs     (T i) = T (abs    i) ; \
   signum  (T i) = T (signum i) ; \
   fromInteger x = T (fromInteger x) }

#define INSTANCE_BOUNDED(T) \
instance Bounded T where { \
   minBound = T minBound ; \
   maxBound = T maxBound }

#define INSTANCE_ENUM(T) \
instance Enum T where { \
   succ           (T i)             = T (succ i) ; \
   pred           (T i)             = T (pred i) ; \
   toEnum               x           = T (toEnum x) ; \
   fromEnum       (T i)             = fromEnum i ; \
   enumFrom       (T i)             = map T (enumFrom i) ; \
   enumFromThen   (T i) (T j)       = map T (enumFromThen i j) ; \
   enumFromTo     (T i) (T j)       = map T (enumFromTo i j) ; \
   enumFromThenTo (T i) (T j) (T k) = map T (enumFromThenTo i j k) }

#define INSTANCE_REAL(T) \
instance Real T where { \
   toRational (T i) = toRational i }

#define INSTANCE_INTEGRAL(T) \
instance Integral T where { \
   (T i) `quot`    (T j) = T (i `quot` j) ; \
   (T i) `rem`     (T j) = T (i `rem`  j) ; \
   (T i) `div`     (T j) = T (i `div`  j) ; \
   (T i) `mod`     (T j) = T (i `mod`  j) ; \
   (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \
   (T i) `divMod`  (T j) = let (d,m) = i `divMod`  j in (T d, T m) ; \
   toInteger (T i)       = toInteger i }

#define INSTANCE_BITS(T) \
instance Bits T where { \
  (T x) .&.     (T y)   = T (x .&.   y) ; \
  (T x) .|.     (T y)   = T (x .|.   y) ; \
  (T x) `xor`   (T y)   = T (x `xor` y) ; \
  complement    (T x)   = T (complement x) ; \
  shift         (T x) n = T (shift x n) ; \
  rotate        (T x) n = T (rotate x n) ; \
  bit                 n = T (bit n) ; \
  setBit        (T x) n = T (setBit x n) ; \
  clearBit      (T x) n = T (clearBit x n) ; \
  complementBit (T x) n = T (complementBit x n) ; \
  testBit       (T x) n = testBit x n ; \
  bitSize       (T x)   = bitSize x ; \
  isSigned      (T x)   = isSigned x }

#define INSTANCE_FRACTIONAL(T) \
instance Fractional T where { \
   (T x) / (T y)  = T (x / y) ; \
   recip   (T x)  = T (recip x) ; \
   fromRational r = T (fromRational r) }

#define INSTANCE_FLOATING(T) \
instance Floating T where { \
   pi                    = pi ; \
   exp   (T x)           = T (exp   x) ; \
   log   (T x)           = T (log   x) ; \
   sqrt  (T x)           = T (sqrt  x) ; \
   (T x) **        (T y) = T (x ** y) ; \
   (T x) `logBase` (T y) = T (x `logBase` y) ; \
   sin   (T x)           = T (sin   x) ; \
   cos   (T x)           = T (cos   x) ; \
   tan   (T x)           = T (tan   x) ; \
   asin  (T x)           = T (asin  x) ; \
   acos  (T x)           = T (acos  x) ; \
   atan  (T x)           = T (atan  x) ; \
   sinh  (T x)           = T (sinh  x) ; \
   cosh  (T x)           = T (cosh  x) ; \
   tanh  (T x)           = T (tanh  x) ; \
   asinh (T x)           = T (asinh x) ; \
   acosh (T x)           = T (acosh x) ; \
   atanh (T x)           = T (atanh x) }

#define INSTANCE_REALFRAC(T) \
instance RealFrac T where { \
   properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \
   truncate (T x) = truncate x ; \
   round    (T x) = round x ; \
   ceiling  (T x) = ceiling x ; \
   floor    (T x) = floor x }

#define INSTANCE_REALFLOAT(T) \
instance RealFloat T where { \
   floatRadix     (T x) = floatRadix x ; \
   floatDigits    (T x) = floatDigits x ; \
   floatRange     (T x) = floatRange x ; \
   decodeFloat    (T x) = decodeFloat x ; \
   encodeFloat m n      = T (encodeFloat m n) ; \
   exponent       (T x) = exponent x ; \
   significand    (T x) = T (significand  x) ; \
   scaleFloat n   (T x) = T (scaleFloat n x) ; \
   isNaN          (T x) = isNaN x ; \
   isInfinite     (T x) = isInfinite x ; \
   isDenormalized (T x) = isDenormalized x ; \
   isNegativeZero (T x) = isNegativeZero x ; \
   isIEEE         (T x) = isIEEE x ; \
   (T x) `atan2`  (T y) = T (x `atan2` y) }

#define INSTANCE_STORABLE(T) \
instance Storable T where { \
   sizeOf    (T x)       = sizeOf x ; \
   alignment (T x)       = alignment x ; \
   peekElemOff a i       = liftM T (peekElemOff (castPtr a) i) ; \
   pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }

#else /* __GLASGOW_HASKELL__ */

--  // GHC can derive any class for a newtype, so we make use of that here...

#define ARITHMETIC_CLASSES  Eq,Ord,Num,Enum,Storable,Real
#define INTEGRAL_CLASSES Bounded,Integral,Bits
#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat

#define ARITHMETIC_TYPE(T,C,S,B) \
newtype T = T B deriving (ARITHMETIC_CLASSES); \
INSTANCE_READ(T,B); \
INSTANCE_SHOW(T,B); \
INSTANCE_TYPEABLE0(T,C,S) ;

#define INTEGRAL_TYPE(T,C,S,B) \
newtype T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \
INSTANCE_READ(T,B); \
INSTANCE_SHOW(T,B); \
INSTANCE_TYPEABLE0(T,C,S) ;

#define FLOATING_TYPE(T,C,S,B) \
newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \
INSTANCE_READ(T,B); \
INSTANCE_SHOW(T,B); \
INSTANCE_TYPEABLE0(T,C,S) ;

#define INSTANCE_READ(T,B) \
instance Read T where { \
   readsPrec            = unsafeCoerce# (readsPrec :: Int -> ReadS B); \
   readList             = unsafeCoerce# (readList  :: ReadS [B]); }

#define INSTANCE_SHOW(T,B) \
instance Show T where { \
   showsPrec            = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \
   show                 = unsafeCoerce# (show :: B -> String); \
   showList             = unsafeCoerce# (showList :: [B] -> ShowS); }

#endif /* __GLASGOW_HASKELL__ */

#endif