{-# LANGUAGE NoMonomorphismRestriction #-}

module NumUtils (showIntAtBase, formatRealFloatAlt, formatHexFloat) where

import Data.Bits
import Data.Char
import Data.Foldable
import Data.Ord
import Data.Semigroup ((<>))
import Data.Tuple
import GHC.Float (
  FFFormat (..),
  roundTo,
 )
import Numeric (floatToDigits)
import Prelude hiding (
  exp,
  foldr,
  (<>),
 )

import Buf
import StrUtils

showIntAtBase ::
  (Buf buf, Show a, Integral a) => a -> (Int -> Char) -> a -> buf
showIntAtBase :: forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase a
base Int -> Char
toChr a
n0
  | a
base forall a. Ord a => a -> a -> Bool
<= a
1 = forall a. HasCallStack => [Char] -> a
error [Char]
"unsupported base"
  | a
n0 forall a. Ord a => a -> a -> Bool
< a
0 = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"negative number " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
n0
  | Bool
otherwise = forall {t}. Buf t => (a, a) -> t -> t
showIt (forall a. Integral a => a -> a -> (a, a)
quotRem a
n0 a
base) forall a. Monoid a => a
mempty
 where
  showIt :: (a, a) -> t -> t
showIt (a
n, a
d) t
r = case a
n of
    a
0 -> t
r'
    a
_ -> (a, a) -> t -> t
showIt (forall a. Integral a => a -> a -> (a, a)
quotRem a
n a
base) t
r'
   where
    r' :: t
r' = forall a. Buf a => Char -> a -> a
cons (Int -> Char
toChr (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d)) t
r

formatRealFloatAlt ::
  (Buf buf, RealFloat a) =>
  FFFormat ->
  Maybe Int ->
  Bool ->
  Bool ->
  a ->
  buf
formatRealFloatAlt :: forall buf a.
(Buf buf, RealFloat a) =>
FFFormat -> Maybe Int -> Bool -> Bool -> a -> buf
formatRealFloatAlt FFFormat
fmt Maybe Int
decs Bool
forceDot Bool
upper a
x
  | forall a. RealFloat a => a -> Bool
isNaN a
x = forall a. Buf a => [Char] -> a
str [Char]
"NaN"
  | forall a. RealFloat a => a -> Bool
isInfinite a
x = forall a. Buf a => [Char] -> a
str forall a b. (a -> b) -> a -> b
$ if a
x forall a. Ord a => a -> a -> Bool
< a
0 then [Char]
"-Infinity" else [Char]
"Infinity"
  | a
x forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isNegativeZero a
x =
    forall a. Buf a => Char -> a -> a
cons
      Char
'-'
      (forall {t}. Buf t => FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
fmt (forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits Integer
10 (- a
x)) Bool
False)
  | Bool
otherwise = forall {t}. Buf t => FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
fmt (forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits Integer
10 a
x) Bool
False
 where
  eChar :: Char
eChar
    | Bool
upper = Char
'E'
    | Bool
otherwise = Char
'e'
  doFmt :: FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
FFFixed ([Int]
digs, Int
exp) Bool
fullRounding
    | Int
exp forall a. Ord a => a -> a -> Bool
< Int
0 =
      FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
FFFixed (forall a. Int -> a -> [a]
replicate (forall a. Num a => a -> a
negate Int
exp) Int
0 forall a. [a] -> [a] -> [a]
++ [Int]
digs, Int
0) Bool
fullRounding
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
part =
      forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
False [Int]
whole forall a. Semigroup a => a -> a -> a
<> (if Bool
forceDot then forall a. Buf a => Char -> a
singleton Char
'.' else forall a. Monoid a => a
mempty)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
whole =
      forall a. Buf a => [Char] -> a
str [Char]
"0." forall a. Semigroup a => a -> a -> a
<> forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
False [Int]
part
    | Bool
otherwise =
      forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
False [Int]
whole forall a. Semigroup a => a -> a -> a
<> forall a. Buf a => Char -> a
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
False [Int]
part
   where
    ([Int]
whole, [Int]
part) =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> [a] -> ([a], [a])
splitAt) (Maybe Int -> ([Int], Int) -> Bool -> ([Int], Int)
toRoundedDigits Maybe Int
decs ([Int]
digs, Int
exp) Bool
fullRounding)
  doFmt FFFormat
FFExponent ([Int
0], Int
_) Bool
_
    | Bool
forceDot = forall a. Buf a => [Char] -> a
str [Char]
"0.e+00"
    | Bool
otherwise = forall a. Buf a => [Char] -> a
str [Char]
"0e+00"
  doFmt FFFormat
FFExponent ([Int]
digs, Int
exp) Bool
fullRounding =
    forall {a}. Buf a => a
shownDigs forall a. Semigroup a => a -> a -> a
<> forall a. Buf a => Char -> a -> a
cons Char
eChar forall {a}. Buf a => a
shownExponent
   where
    shownDigs :: a
shownDigs = case [Int]
digs' of
      [] -> forall a. HasCallStack => a
undefined
      [Int
x'] ->
        forall a. Buf a => Char -> a -> a
cons (Int -> Char
intToDigit Int
x') (if Bool
forceDot then forall a. Buf a => Char -> a
singleton Char
'.' else forall a. Monoid a => a
mempty)
      (Int
x' : [Int]
xs) -> forall a. Buf a => Char -> a -> a
cons (Int -> Char
intToDigit Int
x') (forall a. Buf a => Char -> a -> a
cons Char
'.' (forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
False [Int]
xs))
    digs' :: [Int]
digs' = case Maybe Int
decs of
      Just Int
n ->
        case Int -> Int -> [Int] -> (Int, [Int])
roundTo
          Int
10
          (if Bool
fullRounding then forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
digs) Int
n else Int
n forall a. Num a => a -> a -> a
+ Int
1)
          [Int]
digs of
          (Int
1, [Int]
xs) -> Int
1 forall a. a -> [a] -> [a]
: [Int]
xs
          (Int
_, [Int]
ys) -> [Int]
ys
      Maybe Int
Nothing -> [Int]
digs
    exp' :: Int
exp' = Int
exp forall a. Num a => a -> a -> a
- Int
1
    shownExponent :: a
shownExponent =
      forall a. Buf a => Char -> a -> a
cons (if Int
exp' forall a. Ord a => a -> a -> Bool
< Int
0 then Char
'-' else Char
'+') forall a b. (a -> b) -> a -> b
$
        forall a. Buf a => Int -> Char -> a -> a
justifyRight Int
2 Char
'0' forall a b. (a -> b) -> a -> b
$
          forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase Int
10 Int -> Char
intToDigit forall a b. (a -> b) -> a -> b
$
            forall a. Num a => a -> a
abs Int
exp'
  doFmt FFFormat
FFGeneric ([Int], Int)
d Bool
_ =
    forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a. Buf a => a -> Int
size) [FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
FFFixed ([Int], Int)
d Bool
True, FFFormat -> ([Int], Int) -> Bool -> t
doFmt FFFormat
FFExponent ([Int], Int)
d Bool
True]

toRoundedDigits :: Maybe Int -> ([Int], Int) -> Bool -> ([Int], Int)
toRoundedDigits :: Maybe Int -> ([Int], Int) -> Bool -> ([Int], Int)
toRoundedDigits Maybe Int
Nothing ([Int]
digs, Int
exp) Bool
_ = ([Int]
digs, Int
exp)
toRoundedDigits (Just Int
prec) ([Int]
digs, Int
exp) Bool
fullRounding = ([Int]
digs', Int
exp forall a. Num a => a -> a -> a
+ Int
overflow)
 where
  (Int
overflow, [Int]
digs') =
    Int -> Int -> [Int] -> (Int, [Int])
roundTo
      Int
10
      (if Bool
fullRounding Bool -> Bool -> Bool
&& Int
prec forall a. Ord a => a -> a -> Bool
> Int
exp then forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
digs) Int
prec else Int
prec forall a. Num a => a -> a -> a
+ Int
exp)
      [Int]
digs

fromDigits :: (Buf buf) => Bool -> [Int] -> buf
fromDigits :: forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
upper =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Buf a => Char -> a -> a
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
upper then Char -> Char
toUpper else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit) forall a. Monoid a => a
mempty

formatHexFloat ::
  (Buf buf, RealFloat a) => Maybe Int -> Bool -> Bool -> a -> buf
formatHexFloat :: forall buf a.
(Buf buf, RealFloat a) =>
Maybe Int -> Bool -> Bool -> a -> buf
formatHexFloat Maybe Int
decs Bool
alt Bool
upper a
x = forall {a}. Buf a => ([Int], Int) -> a
doFmt (forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits Integer
2 a
x)
 where
  pChar :: Char
pChar
    | Bool
upper = Char
'P'
    | Bool
otherwise = Char
'p'
  doFmt :: ([Int], Int) -> a
doFmt ([], Int
_) = forall a. HasCallStack => a
undefined
  doFmt ([Int
0], Int
0) = forall a. Buf a => Char -> a -> a
cons Char
'0' (forall a. Buf a => Char -> a -> a
cons Char
pChar (forall a. Buf a => [Char] -> a
str [Char]
"+0"))
  -- possible ghcjs bug - some floats are encoded as ([0,...], exp + 1)
  -- but the first digit should never be 0 unless the input is 0.0
  doFmt (Int
0 : [Int]
bits, Int
exp) = ([Int], Int) -> a
doFmt ([Int]
bits, Int
exp forall a. Num a => a -> a -> a
- Int
1)
  doFmt (Int
_ : [Int]
bits, Int
exp) =
    forall a. Buf a => Char -> a -> a
cons Char
'1' forall a b. (a -> b) -> a -> b
$
      (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
hexDigits) Bool -> Bool -> Bool
|| Bool
alt then forall a. Buf a => Char -> a
singleton Char
'.' else forall a. Monoid a => a
mempty)
        forall a. Semigroup a => a -> a -> a
<> forall buf. Buf buf => Bool -> [Int] -> buf
fromDigits Bool
upper [Int]
hexDigits
        forall a. Semigroup a => a -> a -> a
<> forall a. Buf a => Char -> a
singleton Char
pChar
        forall a. Semigroup a => a -> a -> a
<> (if Int
exp forall a. Ord a => a -> a -> Bool
> Int
0 then forall a. Buf a => Char -> a
singleton Char
'+' else forall a. Monoid a => a
mempty)
        forall a. Semigroup a => a -> a -> a
<> forall a. Buf a => [Char] -> a
str (forall a. Show a => a -> [Char]
show (Int
exp forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
+ Int
overflow))
   where
    hexDigits' :: [Int]
hexDigits' = forall {a}. (Bits a, Num a) => [a] -> [a]
go [Int]
bits
    (Int
overflow, [Int]
hexDigits) = case Maybe Int
decs of
      Just Int
n -> case Int -> Int -> [Int] -> (Int, [Int])
roundTo Int
16 Int
n [Int]
hexDigits' of
        (Int
1, Int
_ : [Int]
digs) -> (Int
1, [Int]
digs)
        (Int, [Int])
x' -> (Int, [Int])
x'
      Maybe Int
Nothing -> (Int
0, [Int]
hexDigits')
    go :: [a] -> [a]
go (a
a : a
b : a
c : a
d : [a]
xs) =
      ((a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
3) forall a. Bits a => a -> a -> a
.|. (a
b forall a. Bits a => a -> Int -> a
`shiftL` Int
2) forall a. Bits a => a -> a -> a
.|. (a
c forall a. Bits a => a -> Int -> a
`shiftL` Int
1) forall a. Bits a => a -> a -> a
.|. a
d) forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
xs
    go [a
a, a
b, a
c] = [a] -> [a]
go [a
a, a
b, a
c, a
0]
    go [a
a, a
b] = [a] -> [a]
go [a
a, a
b, a
0, a
0]
    go [a
a] = [a] -> [a]
go [a
a, a
0, a
0, a
0]
    go [] = []