{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}

-- | Parsers for fractions.
module Data.Textual.Fractional
  (
  -- * Positional numeral systems
    PositionalSystem(..)
  , Binary(..)
  , Octal(..)
  , Decimal(..)
  , Hexadecimal(..)
  , UpHex(..)
  , LowHex(..)
  -- * Sign
  , Sign(..)
  , applySign
  , optMinus
  , optSign
  -- * Optionality characteristic
  , Optional(..)
  , isOptional
  , isRequired
  -- * Fraction parsers
  , optSlash
  , fraction'
  , fraction
  -- * s-fraction parsers
  , decExpSign
  , hexExpSign
  , fractional'
  , fractional
  ) where

import Data.Maybe (isJust)
import Data.Ratio ((%))
import Control.Applicative
import Text.Printer.Fractional (Optional(..), isOptional, isRequired)
import Text.Parser.Combinators ((<?>), unexpected)
import Text.Parser.Char (CharParsing)
import qualified Text.Parser.Char as PC
import Data.Textual.Integral

-- | Accept a slash and return 'Required'. Otherwise return 'Optional'.
optSlash ∷ (Monad μ, CharParsing μ) ⇒ μ Optional
optSlash :: forall (μ :: * -> *). (Monad μ, CharParsing μ) => μ Optional
optSlash = Optional -> (Char -> Optional) -> Maybe Char -> Optional
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Optional
Optional (Optional -> Char -> Optional
forall a b. a -> b -> a
const Optional
Required) (Maybe Char -> Optional) -> μ (Maybe Char) -> μ Optional
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> μ Char -> μ (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> μ Char
forall (m :: * -> *). CharParsing m => Char -> m Char
PC.char Char
'/')

-- | Parse a fraction. The numerator and the denominator are expected to be
--   written in the specified positional numeral system.
fraction' ∷ (PositionalSystem s, Fractional α, Monad μ, CharParsing μ)
          ⇒ μ Sign -- ^ Sign parser
          → s
          → μ Optional -- ^ Numerator/denominator separator parser
          → μ α
fraction' :: forall s α (μ :: * -> *).
(PositionalSystem s, Fractional α, Monad μ, CharParsing μ) =>
μ Sign -> s -> μ Optional -> μ α
fraction' μ Sign
neg s
s μ Optional
den = (μ α -> String -> μ α
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"fraction") (μ α -> μ α) -> μ α -> μ α
forall a b. (a -> b) -> a -> b
$ do
  Integer
n ← μ Sign -> s -> μ Integer
forall s α (μ :: * -> *).
(PositionalSystem s, Num α, Monad μ, CharParsing μ) =>
μ Sign -> s -> μ α
number' μ Sign
neg s
s μ Integer -> String -> μ Integer
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"numerator"
  μ Optional
den μ Optional -> (Optional -> μ α) -> μ α
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Optional
Optional →
      α -> μ α
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (α -> μ α) -> α -> μ α
forall a b. (a -> b) -> a -> b
$ Integer -> α
forall a. Num a => Integer -> a
fromInteger Integer
n
    Optional
Required → do
      Integer
d ← (μ Integer -> String -> μ Integer
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"denominator") (μ Integer -> μ Integer) -> μ Integer -> μ Integer
forall a b. (a -> b) -> a -> b
$ do
        Integer
d ← s -> μ Integer
forall s α (μ :: * -> *).
(PositionalSystem s, Num α, Monad μ, CharParsing μ) =>
s -> μ α
nonNegative s
s
        if Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then String -> μ Integer
forall a. String -> μ a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"zero denominator"
                  else Integer -> μ Integer
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
d
      α -> μ α
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (α -> μ α) -> α -> μ α
forall a b. (a -> b) -> a -> b
$ Rational -> α
forall a. Fractional a => Rational -> a
fromRational (Rational -> α) -> Rational -> α
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d

-- | A shorthand for 'fraction'' 'optMinus' 'Decimal' 'optSlash'.
fraction ∷ (Fractional α, Monad μ, CharParsing μ) ⇒ μ α
fraction :: forall α (μ :: * -> *).
(Fractional α, Monad μ, CharParsing μ) =>
μ α
fraction = μ Sign -> Decimal -> μ Optional -> μ α
forall s α (μ :: * -> *).
(PositionalSystem s, Fractional α, Monad μ, CharParsing μ) =>
μ Sign -> s -> μ Optional -> μ α
fraction' μ Sign
forall (μ :: * -> *). CharParsing μ => μ Sign
optMinus Decimal
Decimal μ Optional
forall (μ :: * -> *). (Monad μ, CharParsing μ) => μ Optional
optSlash

-- | Start of a decimal exponent. Accepts /'e'/ or /'E'/ followed by
--   an optional sign. Otherwise 'Nothing' is returned.
decExpSign ∷ (Monad μ, CharParsing μ) ⇒ μ (Maybe Sign)
decExpSign :: forall (μ :: * -> *). (Monad μ, CharParsing μ) => μ (Maybe Sign)
decExpSign = μ Char -> μ (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> μ Char
forall (m :: * -> *). CharParsing m => String -> m Char
PC.oneOf String
"eE") μ (Maybe Char) -> (Maybe Char -> μ (Maybe Sign)) -> μ (Maybe Sign)
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Maybe Char
Nothing → Maybe Sign -> μ (Maybe Sign)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Sign
forall a. Maybe a
Nothing
               Just Char
_  → Sign -> Maybe Sign
forall a. a -> Maybe a
Just (Sign -> Maybe Sign) -> μ Sign -> μ (Maybe Sign)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> μ Sign
forall (μ :: * -> *). CharParsing μ => μ Sign
optSign

-- | Start of a hexadecimal exponent. Accepts /'p'/ or /'P'/ followed by
--   an optional sign. Otherwise 'Nothing' is returned.
hexExpSign ∷ (Monad μ, CharParsing μ) ⇒ μ (Maybe Sign)
hexExpSign :: forall (μ :: * -> *). (Monad μ, CharParsing μ) => μ (Maybe Sign)
hexExpSign = μ Char -> μ (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> μ Char
forall (m :: * -> *). CharParsing m => String -> m Char
PC.oneOf String
"pP") μ (Maybe Char) -> (Maybe Char -> μ (Maybe Sign)) -> μ (Maybe Sign)
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Maybe Char
Nothing → Maybe Sign -> μ (Maybe Sign)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Sign
forall a. Maybe a
Nothing
               Just Char
_  → Sign -> Maybe Sign
forall a. a -> Maybe a
Just (Sign -> Maybe Sign) -> μ Sign -> μ (Maybe Sign)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> μ Sign
forall (μ :: * -> *). CharParsing μ => μ Sign
optSign

-- | /s/-fraction parser.
fractional' ∷ (PositionalSystem s, Fractional α, Monad μ, CharParsing μ)
            ⇒ μ Sign -- ^ Sign parser.
            → s
            → Optional -- ^ Whether the integer part is optional.
            → μ () -- ^ Dot parser.
            → μ (Maybe Sign) -- ^ Exponent start parser.
            → μ α
fractional' :: forall s α (μ :: * -> *).
(PositionalSystem s, Fractional α, Monad μ, CharParsing μ) =>
μ Sign -> s -> Optional -> μ () -> μ (Maybe Sign) -> μ α
fractional' μ Sign
neg s
s Optional
ip μ ()
dot μ (Maybe Sign)
eneg = (μ α -> String -> μ α
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> (s -> String
forall s. PositionalSystem s => s -> String
systemName s
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-fraction")) (μ α -> μ α) -> μ α -> μ α
forall a b. (a -> b) -> a -> b
$ do
    Sign
sign ← μ Sign
neg μ Sign -> String -> μ Sign
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"sign"
    (Integer
i, Integer
f, Int
fDigits) ← do
      let integral :: μ (Integer, Bool)
integral = do
            Integer
i ← s -> μ Integer
forall s α (μ :: * -> *).
(PositionalSystem s, Num α, Monad μ, CharParsing μ) =>
s -> μ α
nonNegative s
s μ Integer -> String -> μ Integer
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"integer part"
            ((Integer
i, ) (Bool -> (Integer, Bool))
-> (Maybe () -> Bool) -> Maybe () -> (Integer, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe () -> Bool
forall a. Maybe a -> Bool
isJust) (Maybe () -> (Integer, Bool)) -> μ (Maybe ()) -> μ (Integer, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> μ () -> μ (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional μ ()
dot
      (Integer
i, Bool
hasF) ← case Optional
ip of
        Optional
Optional → μ () -> μ (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional μ ()
dot μ (Maybe ())
-> (Maybe () -> μ (Integer, Bool)) -> μ (Integer, Bool)
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe ()
Nothing → μ (Integer, Bool)
integral
          Just ()
_ → (Integer, Bool) -> μ (Integer, Bool)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
0, Bool
True)
        Optional
Required → μ (Integer, Bool)
integral
      (Integer
f, Int
fDigits) ←
        if Bool
hasF
        then do
          let go :: b -> Integer -> μ (Integer, b)
go !b
ds !Integer
f = μ Integer -> μ (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional μ Integer
digit μ (Maybe Integer)
-> (Maybe Integer -> μ (Integer, b)) -> μ (Integer, b)
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                            Just Integer
d  → b -> Integer -> μ (Integer, b)
go (b
ds b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Integer
f Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d)
                            Maybe Integer
Nothing → (Integer, b) -> μ (Integer, b)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
f, b
ds) 
          μ Integer
digit μ Integer -> (Integer -> μ (Integer, Int)) -> μ (Integer, Int)
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Integer -> μ (Integer, Int)
forall {b}. Num b => b -> Integer -> μ (Integer, b)
go (Int
1 ∷ Int) μ (Integer, Int) -> String -> μ (Integer, Int)
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"fractional part"
        else
          (Integer, Int) -> μ (Integer, Int)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
0, Int
0)
      (Integer, Integer, Int) -> μ (Integer, Integer, Int)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
i, Integer
f, Int
fDigits)
    (μ α -> String -> μ α
forall a. μ a -> String -> μ a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"exponent") (μ α -> μ α) -> μ α -> μ α
forall a b. (a -> b) -> a -> b
$ μ (Maybe Sign)
eneg μ (Maybe Sign) -> (Maybe Sign -> μ α) -> μ α
forall a b. μ a -> (a -> μ b) -> μ b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Sign
Nothing | Integer
f Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0    → α -> μ α
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (α -> μ α) -> α -> μ α
forall a b. (a -> b) -> a -> b
$ Integer -> α
forall a. Num a => Integer -> a
fromInteger (Integer -> α) -> Integer -> α
forall a b. (a -> b) -> a -> b
$ Sign -> Integer -> Integer
forall α. Num α => Sign -> α -> α
applySign Sign
sign Integer
i
              | Bool
otherwise → α -> μ α
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (α -> μ α) -> α -> μ α
forall a b. (a -> b) -> a -> b
$ Rational -> α
forall a. Fractional a => Rational -> a
fromRational
                                   (Rational -> α) -> Rational -> α
forall a b. (a -> b) -> a -> b
$ Sign -> Rational -> Rational
forall α. Num α => Sign -> α -> α
applySign Sign
sign
                                   (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
i Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Integer
f Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
fDigits
      Just Sign
esign → do
        Int
e ← Decimal -> μ Int
forall s α (μ :: * -> *).
(PositionalSystem s, Ord α, Bounded α, Integral α, Monad μ,
 CharParsing μ) =>
s -> μ α
nnBounded Decimal
Decimal
        α -> μ α
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return (α -> μ α) -> α -> μ α
forall a b. (a -> b) -> a -> b
$ Sign -> α -> α
forall α. Num α => Sign -> α -> α
applySign Sign
sign (α -> α) -> α -> α
forall a b. (a -> b) -> a -> b
$ case Sign
esign of
          Sign
NonNegative → case Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fDigits of
            Int
e₁ | Int
e₁ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0   → Integer -> α
forall a. Num a => Integer -> a
fromInteger (Integer -> α) -> Integer -> α
forall a b. (a -> b) -> a -> b
$ Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
f Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e₁
               | Bool
otherwise → Rational -> α
forall a. Fractional a => Rational -> a
fromRational
                           (Rational -> α) -> Rational -> α
forall a b. (a -> b) -> a -> b
$ Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e)
                           Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Integer
i Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int -> Int
forall a. Num a => a -> a
negate Int
e₁
          Sign
NonPositive → Rational -> α
forall a. Fractional a => Rational -> a
fromRational
                      (Rational -> α) -> Rational -> α
forall a b. (a -> b) -> a -> b
$ Integer
i Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Integer
f Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
radix Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
fDigits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e)
  where 
    radix :: Integer
radix = s -> Integer
forall α. Num α => s -> α
forall s α. (PositionalSystem s, Num α) => s -> α
radixIn s
s
    digit :: μ Integer
digit = s -> μ Integer
forall s α (μ :: * -> *).
(PositionalSystem s, Num α, CharParsing μ) =>
s -> μ α
digitIn s
s

-- | Decimal fraction parser.
fractional ∷ (Monad μ, Fractional α, CharParsing μ) ⇒ μ α
fractional :: forall (μ :: * -> *) α.
(Monad μ, Fractional α, CharParsing μ) =>
μ α
fractional = μ Sign -> Decimal -> Optional -> μ () -> μ (Maybe Sign) -> μ α
forall s α (μ :: * -> *).
(PositionalSystem s, Fractional α, Monad μ, CharParsing μ) =>
μ Sign -> s -> Optional -> μ () -> μ (Maybe Sign) -> μ α
fractional' μ Sign
forall (μ :: * -> *). CharParsing μ => μ Sign
optMinus Decimal
Decimal Optional
Required
                         (Char -> μ Char
forall (m :: * -> *). CharParsing m => Char -> m Char
PC.char Char
'.' μ Char -> μ () -> μ ()
forall a b. μ a -> μ b -> μ b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> μ ()
forall a. a -> μ a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) μ (Maybe Sign)
forall (μ :: * -> *). (Monad μ, CharParsing μ) => μ (Maybe Sign)
decExpSign