{-# LANGUAGE BangPatterns, DeriveDataTypeable, Haskell2010, OverloadedStrings #-}
-- |
-- Module      :  Data.Picoparsec.Number
-- Copyright   :  Bryan O'Sullivan 2011, Mario Blažević <blamario@yahoo.com> 2014
-- License     :  BSD3
--
-- Maintainer  :  Mario Blažević
-- Stability   :  experimental
-- Portability :  unknown
--
-- This module is deprecated, and both the module and 'Number' type
-- will be removed in the next major release.  Use the
-- <http://hackage.haskell.org/package/scientific scientific> package
-- and the 'Data.Scientific.Scientific' type instead.
--
-- A simple number type, useful for parsing both exact and inexact
-- quantities without losing much precision.
module Data.Picoparsec.Number (
    Number(..)

    -- * Numeric parsers
    , decimal
    , hexadecimal
    , signed
    , double
    , number
    , rational
    , scientific
    ) where

import Prelude hiding (length)

import Control.Applicative (pure, (*>), (<$>), (<|>))
import Control.DeepSeq (NFData(rnf))
import Control.Monad (void, when)
import Data.Monoid.Factorial (length)
import Data.Monoid.Textual (TextualMonoid, foldl_')
import Data.Bits (Bits, (.|.), shiftL)
import Data.Char (digitToInt, isDigit, isHexDigit, ord)
import Data.Data (Data)
import Data.Function (on)
import Data.Scientific (Scientific, coefficient, base10Exponent)
import qualified Data.Scientific as Sci (scientific)
import Data.Typeable (Typeable)
import GHC.Exts (inline)

import Data.Picoparsec (Parser, string)
import qualified Data.Picoparsec.Monoid.Internal as I

-- | A numeric type that can represent integers accurately, and
-- floating point numbers to the precision of a 'Double'.
data Number = I !Integer
            | D {-# UNPACK #-} !Double
              deriving (Typeable, Data)

instance Show Number where
    show (I a) = show a
    show (D a) = show a

instance NFData Number where
    rnf (I _) = ()
    rnf (D _) = ()
    {-# INLINE rnf #-}

binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)
      -> Number -> Number -> a
binop _ d (D a) (D b) = d a b
binop i _ (I a) (I b) = i a b
binop _ d (D a) (I b) = d a (fromIntegral b)
binop _ d (I a) (D b) = d (fromIntegral a) b
{-# INLINE binop #-}

instance Eq Number where
    (==) = binop (==) (==)
    {-# INLINE (==) #-}

    (/=) = binop (/=) (/=)
    {-# INLINE (/=) #-}

instance Ord Number where
    (<) = binop (<) (<)
    {-# INLINE (<) #-}

    (<=) = binop (<=) (<=)
    {-# INLINE (<=) #-}

    (>) = binop (>) (>)
    {-# INLINE (>) #-}

    (>=) = binop (>=) (>=)
    {-# INLINE (>=) #-}

    compare = binop compare compare
    {-# INLINE compare #-}

instance Num Number where
    (+) = binop (((I$!).) . (+)) (((D$!).) . (+))
    {-# INLINE (+) #-}

    (-) = binop (((I$!).) . (-)) (((D$!).) . (-))
    {-# INLINE (-) #-}

    (*) = binop (((I$!).) . (*)) (((D$!).) . (*))
    {-# INLINE (*) #-}

    abs (I a) = I $! abs a
    abs (D a) = D $! abs a
    {-# INLINE abs #-}

    negate (I a) = I $! negate a
    negate (D a) = D $! negate a
    {-# INLINE negate #-}

    signum (I a) = I $! signum a
    signum (D a) = D $! signum a
    {-# INLINE signum #-}

    fromInteger = (I$!) . fromInteger
    {-# INLINE fromInteger #-}

instance Real Number where
    toRational (I a) = fromIntegral a
    toRational (D a) = toRational a
    {-# INLINE toRational #-}

instance Fractional Number where
    fromRational = (D$!) . fromRational
    {-# INLINE fromRational #-}

    (/) = binop (((D$!).) . (/) `on` fromIntegral)
                (((D$!).) . (/))
    {-# INLINE (/) #-}

    recip (I a) = D $! recip (fromIntegral a)
    recip (D a) = D $! recip a
    {-# INLINE recip #-}

instance RealFrac Number where
    properFraction (I a) = (fromIntegral a,0)
    properFraction (D a) = case properFraction a of
                             (i,d) -> (i,D d)
    {-# INLINE properFraction #-}
    truncate (I a) = fromIntegral a
    truncate (D a) = truncate a
    {-# INLINE truncate #-}
    round (I a) = fromIntegral a
    round (D a) = round a
    {-# INLINE round #-}
    ceiling (I a) = fromIntegral a
    ceiling (D a) = ceiling a
    {-# INLINE ceiling #-}
    floor (I a) = fromIntegral a
    floor (D a) = floor a
    {-# INLINE floor #-}

-- | Parse and decode an unsigned hexadecimal number.  The hex digits
-- @\'a\'@ through @\'f\'@ may be upper or lower case.
--
-- This parser does not accept a leading @\"0x\"@ string.
hexadecimal :: (TextualMonoid t, Integral a, Bits a) => Parser t a
hexadecimal = foldl_' step 0 <$> I.takeCharsWhile1 isHexDigit
  where step a c = (a `shiftL` 4) .|. fromIntegral (digitToInt c)
{-# INLINEABLE hexadecimal #-}

-- | Parse and decode an unsigned decimal number.
decimal :: (TextualMonoid t, Integral a) => Parser t a
decimal = foldl_' step 0 <$> I.takeCharsWhile1 isDigit
  where step a c = a * 10 + fromIntegral (digitToInt c)
{-# INLINEABLE decimal #-}

-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign
-- character.
signed :: (TextualMonoid t, Num a) => Parser t a -> Parser t a
{-# INLINEABLE signed #-}
signed p = (negate <$> (string "-" *> p))
       <|> (string "+" *> p)
       <|> p

-- | Parse a rational number.
--
-- This parser accepts an optional leading sign character, followed by
-- at least one decimal digit.  The syntax similar to that accepted by
-- the 'read' function, with the exception that a trailing @\'.\'@ or
-- @\'e\'@ /not/ followed by a number is not consumed.
--
-- Examples with behaviour identical to 'read', if you feed an empty
-- continuation to the first result:
--
-- >rational "3"     == Done 3.0 ""
-- >rational "3.1"   == Done 3.1 ""
-- >rational "3e4"   == Done 30000.0 ""
-- >rational "3.1e4" == Done 31000.0, ""
--
-- Examples with behaviour identical to 'read':
--
-- >rational ".3"    == Fail "input does not start with a digit"
-- >rational "e3"    == Fail "input does not start with a digit"
--
-- Examples of differences from 'read':
--
-- >rational "3.foo" == Done 3.0 ".foo"
-- >rational "3e"    == Done 3.0 "e"
--
-- This function does not accept string representations of \"NaN\" or
-- \"Infinity\".
rational :: (TextualMonoid t, Fractional a) => Parser t a
rational = inline scientifically realToFrac
{-# INLINABLE rational #-}

-- | Parse a rational number.
--
-- The syntax accepted by this parser is the same as for 'rational'.
--
-- /Note/: This function is almost ten times faster than 'rational',
-- but is slightly less accurate.
--
-- The 'Double' type supports about 16 decimal places of accuracy.
-- For 94.2% of numbers, this function and 'rational' give identical
-- results, but for the remaining 5.8%, this function loses precision
-- around the 15th decimal place.  For 0.001% of numbers, this
-- function will lose precision at the 13th or 14th decimal place.
--
-- This function does not accept string representations of \"NaN\" or
-- \"Infinity\".
double :: TextualMonoid t => Parser t Double
double = rational
{-# INLINE double #-}

-- | Parse a number, attempting to preserve both speed and precision.
--
-- The syntax accepted by this parser is the same as for 'rational'.
--
-- /Note/: This function is almost ten times faster than 'rational'.
-- On integral inputs, it gives perfectly accurate answers, and on
-- floating point inputs, it is slightly less accurate than
-- 'rational'.
--
-- This function does not accept string representations of \"NaN\" or
-- \"
number :: TextualMonoid t => Parser t Number
number = inline scientifically $ \s ->
            let e = base10Exponent s
                c = coefficient s
            in if e >= 0
               then I (c * 10 ^ e)
               else D (fromInteger c / 10 ^ negate e)
{-# INLINABLE number #-}

-- | Parse a scientific number.
--
-- The syntax accepted by this parser is the same as for 'rational'.
scientific :: TextualMonoid t => Parser t Scientific
scientific = inline scientifically id
{-# INLINABLE scientific #-}

scientifically :: TextualMonoid t => (Scientific -> a) -> Parser t a
scientifically h = do
  sign <- I.peekChar'
  let !positive = sign /= '-'
  when (sign == '+' || sign == '-') $
    void I.anyToken

  n <- decimal

  let f fracDigits = Sci.scientific (foldl_' step n fracDigits)
                                    (negate $ length fracDigits)
      step a c = a * 10 + fromIntegral (ord c - ord '0')

  dotty <- I.peekChar
  s <- case dotty of
         Just '.' -> I.anyToken *> (f <$> I.takeCharsWhile isDigit)
         _        -> pure (Sci.scientific n 0)

  let !signedCoeff | positive  =          coefficient s
                   | otherwise = negate $ coefficient s

  (I.satisfyChar (\c -> c == 'e' || c == 'E') *>
      fmap (h . Sci.scientific signedCoeff . (base10Exponent s +)) (signed decimal)) <|>
    return (h $ Sci.scientific signedCoeff   (base10Exponent s))
{-# INLINABLE scientifically #-}