-- SPDX-FileCopyrightText: 1999-2001 Daan Leijen
-- SPDX-FileCopyrightText: 2007 Paolo Martini
-- SPDX-FileCopyrightText: 2013-2014 Christian Maeder <chr.maeder@web.de>
-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: BSD-2-Clause AND GPL-3.0-only

module Language.QBE.Numbers where

import Control.Monad (ap)
import Data.Char (digitToInt)
import Text.Parsec

-- ** float parts

-- | parse a floating point number given the number before a dot, e or E
fractExponent :: (Floating f, Stream s m Char) => Integer -> ParsecT s u m f
fractExponent :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Integer -> ParsecT s u m f
fractExponent Integer
i = Integer -> Bool -> ParsecT s u m f
forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Integer -> Bool -> ParsecT s u m f
fractExp Integer
i Bool
False

-- | parse a floating point number given the number before a dot, e or E
fractExp ::
  (Floating f, Stream s m Char) =>
  Integer ->
  Bool ->
  ParsecT s u m f
fractExp :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Integer -> Bool -> ParsecT s u m f
fractExp Integer
i Bool
b = Integer
-> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Integer
-> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
genFractExp Integer
i (Bool -> ParsecT s u m f
forall f s (m :: * -> *) u.
(Fractional f, Stream s m Char) =>
Bool -> ParsecT s u m f
fraction Bool
b) ParsecT s u m (f -> f)
forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
ParsecT s u m (f -> f)
exponentFactor

-- | parse a floating point number given the number before the fraction and
-- exponent
genFractExp ::
  (Floating f, Stream s m Char) =>
  Integer ->
  ParsecT s u m f ->
  ParsecT s u m (f -> f) ->
  ParsecT s u m f
genFractExp :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Integer
-> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
genFractExp Integer
i ParsecT s u m f
frac ParsecT s u m (f -> f)
expo = case Integer -> f
forall a. Num a => Integer -> a
fromInteger Integer
i of
  f
f -> f -> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
f -> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
genFractAndExp f
f ParsecT s u m f
frac ParsecT s u m (f -> f)
expo ParsecT s u m f -> ParsecT s u m f -> ParsecT s u m f
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ((f -> f) -> f) -> ParsecT s u m (f -> f) -> ParsecT s u m f
forall a b. (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$ f
f) ParsecT s u m (f -> f)
expo

-- | parse a floating point number given the number before the fraction and
-- exponent that must follow the fraction
genFractAndExp ::
  (Floating f, Stream s m Char) =>
  f ->
  ParsecT s u m f ->
  ParsecT s u m (f -> f) ->
  ParsecT s u m f
genFractAndExp :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
f -> ParsecT s u m f -> ParsecT s u m (f -> f) -> ParsecT s u m f
genFractAndExp f
f ParsecT s u m f
frac = ParsecT s u m ((f -> f) -> f)
-> ParsecT s u m (f -> f) -> ParsecT s u m f
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ((f -> (f -> f) -> f)
-> ParsecT s u m f -> ParsecT s u m ((f -> f) -> f)
forall a b. (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((f -> f) -> f -> f) -> f -> (f -> f) -> f
forall a b c. (a -> b -> c) -> b -> a -> c
flip (f -> f) -> f -> f
forall a. a -> a
id (f -> (f -> f) -> f) -> (f -> f) -> f -> (f -> f) -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f
f +)) ParsecT s u m f
frac) (ParsecT s u m (f -> f) -> ParsecT s u m f)
-> (ParsecT s u m (f -> f) -> ParsecT s u m (f -> f))
-> ParsecT s u m (f -> f)
-> ParsecT s u m f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f -> f) -> ParsecT s u m (f -> f) -> ParsecT s u m (f -> f)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option f -> f
forall a. a -> a
id

-- | parse a floating point exponent starting with e or E
exponentFactor :: (Floating f, Stream s m Char) => ParsecT s u m (f -> f)
exponentFactor :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
ParsecT s u m (f -> f)
exponentFactor = [Char] -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"eE" ParsecT s u m Char
-> ParsecT s u m (f -> f) -> ParsecT s u m (f -> f)
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s u m (f -> f)
forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Int -> ParsecT s u m (f -> f)
extExponentFactor Int
10 ParsecT s u m (f -> f) -> [Char] -> ParsecT s u m (f -> f)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"exponent"

-- | parse a signed decimal and compute the exponent factor given a base.
-- For hexadecimal exponential notation (IEEE 754) the base is 2 and the
-- leading character a p.
extExponentFactor ::
  (Floating f, Stream s m Char) =>
  Int -> ParsecT s u m (f -> f)
extExponentFactor :: forall f s (m :: * -> *) u.
(Floating f, Stream s m Char) =>
Int -> ParsecT s u m (f -> f)
extExponentFactor Int
base =
  (Integer -> f -> f)
-> ParsecT s u m Integer -> ParsecT s u m (f -> f)
forall a b. (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f -> f -> f) -> f -> f -> f
forall a b c. (a -> b -> c) -> b -> a -> c
flip f -> f -> f
forall a. Num a => a -> a -> a
(*) (f -> f -> f) -> (Integer -> f) -> Integer -> f -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer -> f
forall f. Floating f => Int -> Integer -> f
exponentValue Int
base) (ParsecT s u m (Integer -> Integer)
-> ParsecT s u m Integer -> ParsecT s u m Integer
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ParsecT s u m (Integer -> Integer)
forall a s (m :: * -> *) u.
(Num a, Stream s m Char) =>
ParsecT s u m (a -> a)
sign (ParsecT s u m Integer
forall i s (m :: * -> *) u.
(Integral i, Stream s m Char) =>
ParsecT s u m i
decimal ParsecT s u m Integer -> [Char] -> ParsecT s u m Integer
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"exponent"))

-- | compute the factor given by the number following e or E. This
-- implementation uses @**@ rather than @^@ for more efficiency for large
-- integers.
exponentValue :: (Floating f) => Int -> Integer -> f
exponentValue :: forall f. Floating f => Int -> Integer -> f
exponentValue Int
base = (Int -> f
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base **) (f -> f) -> (Integer -> f) -> Integer -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> f
forall a. Num a => Integer -> a
fromInteger

-- ** fractional parts

-- | optionally parse a dot followed by decimal digits as fractional part.
-- if there is no dot, and the fractional part is not required (as indicated
-- by the predicate argument), then 0.0 is returned.
fraction :: (Fractional f, Stream s m Char) => Bool -> ParsecT s u m f
fraction :: forall f s (m :: * -> *) u.
(Fractional f, Stream s m Char) =>
Bool -> ParsecT s u m f
fraction Bool
reqDigit = do
  Bool
hasDot <- (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT s u m Char -> ParsecT s u m Bool -> ParsecT s u m Bool
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ParsecT s u m Bool
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) ParsecT s u m Bool -> ParsecT s u m Bool -> ParsecT s u m Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool -> ParsecT s u m Bool
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  if Bool
hasDot
    then Bool -> Int -> ParsecT s u m Char -> ParsecT s u m f
forall f s (m :: * -> *) u.
(Fractional f, Stream s m Char) =>
Bool -> Int -> ParsecT s u m Char -> ParsecT s u m f
baseFraction Bool
reqDigit Int
10 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    else if Bool
reqDigit then [Char] -> ParsecT s u m f
forall s u (m :: * -> *) a. [Char] -> ParsecT s u m a
parserFail [Char]
"no dot in fraction" else f -> ParsecT s u m f
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f
0.0

-- | parse base dependent digits (usually after dot) as fractional part
baseFraction ::
  (Fractional f, Stream s m Char) =>
  Bool ->
  Int ->
  ParsecT s u m Char ->
  ParsecT s u m f
baseFraction :: forall f s (m :: * -> *) u.
(Fractional f, Stream s m Char) =>
Bool -> Int -> ParsecT s u m Char -> ParsecT s u m f
baseFraction Bool
requireDigit Int
base ParsecT s u m Char
baseDigit =
  ([Char] -> f) -> ParsecT s u m [Char] -> ParsecT s u m f
forall a b. (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (Int -> [Char] -> f
forall f. Fractional f => Int -> [Char] -> f
fractionValue Int
base)
    ((if Bool
requireDigit then ParsecT s u m Char -> ParsecT s u m [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 else ParsecT s u m Char -> ParsecT s u m [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many) ParsecT s u m Char
baseDigit ParsecT s u m [Char] -> [Char] -> ParsecT s u m [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"fraction")
    ParsecT s u m f -> [Char] -> ParsecT s u m f
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"fraction"

-- | compute the fraction given by a sequence of digits following the dot.
-- Only one division is performed and trailing zeros are ignored.
fractionValue :: (Fractional f) => Int -> String -> f
fractionValue :: forall f. Fractional f => Int -> [Char] -> f
fractionValue Int
base =
  (f -> f -> f) -> (f, f) -> f
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry f -> f -> f
forall a. Fractional a => a -> a -> a
(/)
    ((f, f) -> f) -> ([Char] -> (f, f)) -> [Char] -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((f, f) -> Char -> (f, f)) -> (f, f) -> [Char] -> (f, f)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
      ( \(f
s, f
p) Char
d ->
          (f
p f -> f -> f
forall a. Num a => a -> a -> a
* Int -> f
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d) f -> f -> f
forall a. Num a => a -> a -> a
+ f
s, f
p f -> f -> f
forall a. Num a => a -> a -> a
* Int -> f
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base)
      )
      (f
0, f
1)
    ([Char] -> (f, f)) -> ([Char] -> [Char]) -> [Char] -> (f, f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0')
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse

-- * integers and naturals

-- | parse a negative or a positive number (returning 'negate' or 'id').
-- positive numbers are NOT allowed to be prefixed by a plus sign.
signMinus :: (Num a, Stream s m Char) => ParsecT s u m (a -> a)
signMinus :: forall a s (m :: * -> *) u.
(Num a, Stream s m Char) =>
ParsecT s u m (a -> a)
signMinus = (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT s u m Char
-> ParsecT s u m (a -> a) -> ParsecT s u m (a -> a)
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> a) -> ParsecT s u m (a -> a)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. Num a => a -> a
negate) ParsecT s u m (a -> a)
-> ParsecT s u m (a -> a) -> ParsecT s u m (a -> a)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (a -> a) -> ParsecT s u m (a -> a)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. a -> a
id

-- | parse an optional plus or minus sign, returning 'negate' or 'id'
sign :: (Num a, Stream s m Char) => ParsecT s u m (a -> a)
sign :: forall a s (m :: * -> *) u.
(Num a, Stream s m Char) =>
ParsecT s u m (a -> a)
sign = (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT s u m Char
-> ParsecT s u m (a -> a) -> ParsecT s u m (a -> a)
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> a) -> ParsecT s u m (a -> a)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. Num a => a -> a
negate) ParsecT s u m (a -> a)
-> ParsecT s u m (a -> a) -> ParsecT s u m (a -> a)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ParsecT s u m Char -> ParsecT s u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+') ParsecT s u m ()
-> ParsecT s u m (a -> a) -> ParsecT s u m (a -> a)
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> a) -> ParsecT s u m (a -> a)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. a -> a
id)

-- | parse plain non-negative decimal numbers given by a non-empty sequence
-- of digits
decimal :: (Integral i, Stream s m Char) => ParsecT s u m i
decimal :: forall i s (m :: * -> *) u.
(Integral i, Stream s m Char) =>
ParsecT s u m i
decimal = Int -> ParsecT s u m Char -> ParsecT s u m i
forall i s (m :: * -> *) t u.
(Integral i, Stream s m t) =>
Int -> ParsecT s u m Char -> ParsecT s u m i
number Int
10 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

-- ** natural parts

-- | parse a hexadecimal number
hexnum :: (Integral i, Stream s m Char) => ParsecT s u m i
hexnum :: forall i s (m :: * -> *) u.
(Integral i, Stream s m Char) =>
ParsecT s u m i
hexnum = Int -> ParsecT s u m Char -> ParsecT s u m i
forall i s (m :: * -> *) t u.
(Integral i, Stream s m t) =>
Int -> ParsecT s u m Char -> ParsecT s u m i
number Int
16 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit

-- | parse an octal number
octnum :: (Integral i, Stream s m Char) => ParsecT s u m i
octnum :: forall i s (m :: * -> *) u.
(Integral i, Stream s m Char) =>
ParsecT s u m i
octnum = Int -> ParsecT s u m Char -> ParsecT s u m i
forall i s (m :: * -> *) t u.
(Integral i, Stream s m t) =>
Int -> ParsecT s u m Char -> ParsecT s u m i
number Int
8 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
octDigit

-- | parse a non-negative number given a base and a parser for the digits
number ::
  (Integral i, Stream s m t) =>
  Int ->
  ParsecT s u m Char ->
  ParsecT s u m i
number :: forall i s (m :: * -> *) t u.
(Integral i, Stream s m t) =>
Int -> ParsecT s u m Char -> ParsecT s u m i
number Int
base ParsecT s u m Char
baseDigit = do
  i
n <- ([Char] -> i) -> ParsecT s u m [Char] -> ParsecT s u m i
forall a b. (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [Char] -> i
forall i. Integral i => Int -> [Char] -> i
numberValue Int
base) (ParsecT s u m Char -> ParsecT s u m [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s u m Char
baseDigit)
  i -> ParsecT s u m i -> ParsecT s u m i
forall a b. a -> b -> b
seq i
n (i -> ParsecT s u m i
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return i
n)

-- | compute the value from a string of digits using a base
numberValue :: (Integral i) => Int -> String -> i
numberValue :: forall i. Integral i => Int -> [Char] -> i
numberValue Int
base =
  (i -> Char -> i) -> i -> [Char] -> i
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\i
x -> ((Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base i -> i -> i
forall a. Num a => a -> a -> a
* i
x) +) (i -> i) -> (Char -> i) -> Char -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> i) -> (Char -> Int) -> Char -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) i
0