{-# LANGUAGE DeriveDataTypeable #-}
module Numeric.HugeFloat where

import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.TypeLevel (toInt, Pos, D64, D128, D192, D256, D320, D384, D448, D512)
import Data.Bits (shiftL, shiftR)
import Data.Ratio (numerator, denominator)
import Numeric (showFloat, readSigned, readFloat)

import Debug.Trace

type F1 = HugeFloat D64
type F2 = HugeFloat D128
type F3 = HugeFloat D192
type F4 = HugeFloat D256
type F5 = HugeFloat D320
type F6 = HugeFloat D384
type F7 = HugeFloat D448
type F8 = HugeFloat D512

data HugeFloat prec = HugeFloat !Integer !Int
  deriving (Data, Typeable)

hugeFloat :: Pos prec => prec -> Integer -> Int -> HugeFloat prec
hugeFloat p m e
  | m == 0 = HugeFloat 0 0
  | e > maxB = error "+huge"
  | e < minB = error "-huge"
  | abs m >= maxM = hugeFloat p (m `shiftR` 1) (e + 1)
  | abs m <  minM = hugeFloat p (m `shiftL` 1) (e - 1)
  | otherwise = HugeFloat m e
  where
    bits = toInt p
    maxM = 1 `shiftL` bits
    minM = 1 `shiftL` (bits - 1)
    (minB, maxB) = floatRange (hugeFloat p undefined undefined)

precision :: HugeFloat prec -> prec
precision _ = undefined

refloat :: (Pos p1, Pos p2) => HugeFloat p1 -> HugeFloat p2
refloat = uncurry encodeFloat . decodeFloat

instance Pos prec => Show (HugeFloat prec) where
  show = flip showFloat ""

instance Pos prec => Read (HugeFloat prec) where
  readsPrec _ = readSigned readFloat

instance Pos prec => Eq (HugeFloat prec) where
  HugeFloat m1 e1 == HugeFloat m2 e2 = m1 == m2 && e1 == e2
  HugeFloat m1 e1 /= HugeFloat m2 e2 = m1 /= m2 || e1 /= e2

instance Pos prec => Ord (HugeFloat prec) where
  HugeFloat m1 e1 `compare` HugeFloat m2 e2 =
    case s1 `compare` s2 of
      LT -> LT
      GT -> GT
      EQ -> case s1 of
        0 -> EQ
        1 -> case e1 `compare` e2 of
          LT -> LT
          GT -> GT
          EQ -> m1 `compare` m2
        -1 -> case e1 `compare` e2 of
          LT -> GT
          GT -> LT
          EQ -> m1 `compare` m2
    where
      s1 = signum m1
      s2 = signum m2

instance Pos prec => Num (HugeFloat prec) where
  HugeFloat m1 e1 + HugeFloat m2 e2 =
    case e1 `compare` e2 of
      LT -> hugeFloat undefined ((m1 `shiftR` (e2 - e1)) + m2) e2
      EQ -> hugeFloat undefined (m1           +            m2) e1
      GT -> hugeFloat undefined (m1 + (m2 `shiftR` (e1 - e2))) e1
  f1@(HugeFloat m1 e1) * HugeFloat m2 e2 =
    hugeFloat undefined ((m1 * m2) `shiftR` s) (e1 + e2 + s) where s = toInt (precision f1) - 2
  negate (HugeFloat m e) =  HugeFloat (negate m) e
  f1 - f2 = f1 + negate f2
  abs (HugeFloat m e) = HugeFloat (abs m) e
  signum (HugeFloat m _) = case signum m of
    -1 -> -1
    0 -> 0
    1 -> 1
  fromInteger i = hugeFloat undefined i 0

instance Pos prec => Fractional (HugeFloat prec) where
  f1@(HugeFloat m1 e1) / HugeFloat m2 e2 =
    hugeFloat undefined ((signum m1 * signum m2) * ((abs m1 `shiftL` s) `div` abs m2)) (e1 - e2 - s) where s = toInt (precision f1) + 2
  fromRational a = fromInteger (numerator a) / fromInteger (denominator a)

instance Pos prec => Real (HugeFloat prec) where
  toRational (HugeFloat m e) = toRational m * 2 ^^ e

instance Pos prec => RealFrac (HugeFloat prec) where
  properFraction = fmap fromRational . properFraction . toRational

instance Pos prec => Floating (HugeFloat prec) where
  pi = undefined
  exp = undefined
  sqrt = undefined
  log = undefined
  (**) = undefined
  logBase = undefined
  sin = undefined
  cos = undefined
  tan = undefined
  asin = undefined
  acos = undefined
  atan = undefined
  sinh = undefined
  cosh = undefined
  tanh = undefined
  asinh = undefined
  acosh = undefined
  atanh = undefined

instance Pos prec => RealFloat (HugeFloat prec) where
  decodeFloat (HugeFloat m e) = (m, e)
  encodeFloat m e = hugeFloat undefined m e
  floatRadix _ = 2
  floatDigits f = toInt (precision f)
  floatRange _ = (minBound, maxBound) -- fails
--  floatRange _ = (minBound `div` 2, maxBound `div` 2) -- works?
  isNaN _ = False
  isInfinite _ = False
  isDenormalized _ = False
  isNegativeZero _ = False
  isIEEE _ = False