{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

-- | Flexible numeric parsers for real-world programming languages.
-- These parsers aim to be a superset of the numeric syntaxes across
-- the most popular programming languages.
--
-- All parsers assume any trailing whitespace has already been
-- consumed, and places no requirement for an @endOfInput@ at the end
-- of a literal. Be sure to handle these in a calling context. These
-- parsers do not use 'Text.Parser.Token.TokenParsing', and therefore
-- may fail while consuming input, depending on if you use a parser
-- that automatically backtracks or not. Apply 'try' if needed.
module Numeric.Parse.Flexible
  ( integer,
    natural,
    decimal,
    hexadecimal,
    octal,
    binary,
    floating,
    signed,
    imaginary,
  )
where

import Control.Applicative
import Control.Monad hiding (fail)
import Data.Scientific hiding (scientific)
import Numeric
import Text.Parser.Char
import Text.Parser.Combinators
import Text.Read (readMaybe)
import Prelude hiding (exponent, fail, takeWhile)
import Data.Complex
import Numeric.Natural (Natural)

-- | Parse an integer in 'decimal', 'hexadecimal', 'octal', or 'binary', with optional leading sign.
--
-- Note that because the 'octal' parser takes primacy over 'decimal', numbers with a leading
-- @0@ will be parsed as octal. This is unfortunate, but matches the behavior
-- of C, Python, and Ruby.
integer :: (CharParsing m, Monad m) => m Integer
integer :: m Integer
integer = m Integer -> m Integer
forall a (m :: * -> *). (CharParsing m, Num a) => m a -> m a
signed ([m Integer] -> m Integer
forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *).
(Eq a, Num a, CharParsing m, Monad m) =>
m a
hexadecimal, m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *). (Num a, CharParsing m, Monad m) => m a
octal, m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *).
(Show a, Num a, CharParsing m, Monad m) =>
m a
binary, m Integer
forall (m :: * -> *). (CharParsing m, Monad m) => m Integer
decimal])

-- | Parse a natural number in 'decimal', 'hexadecimal', 'octal', or 'binary'. As with 'integer',
-- a leading @0@ is interpreted as octal. Leading signs are not accepted.
natural :: (CharParsing m, Monad m) => m Natural
natural :: m Natural
natural = Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> m Integer -> m Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m Integer] -> m Integer
forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *).
(Eq a, Num a, CharParsing m, Monad m) =>
m a
hexadecimal, m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *). (Num a, CharParsing m, Monad m) => m a
octal, m Integer -> m Integer
forall (m :: * -> *) a. Parsing m => m a -> m a
try m Integer
forall a (m :: * -> *).
(Show a, Num a, CharParsing m, Monad m) =>
m a
binary, m Integer
forall (m :: * -> *). (CharParsing m, Monad m) => m Integer
decimal]

-- | Parse an integer in base 10.
--
-- Accepts @0..9@ and underscore separators. No leading signs are accepted.
decimal :: (CharParsing m, Monad m) => m Integer
decimal :: m Integer
decimal = do
  String
contents <- m Char -> m String
forall (m :: * -> *). CharParsing m => m Char -> m String
withUnder m Char
forall (m :: * -> *). CharParsing m => m Char
digit
  String -> m Integer
forall a (m :: * -> *). (Read a, CharParsing m) => String -> m a
attempt String
contents

-- | Parse a number in hexadecimal.
--
-- Requires a @0x@ or @0X@ prefix. No leading signs are accepted.
-- Accepts @A..F@, @a..f@, @0..9@ and underscore separators.
hexadecimal :: forall a m. (Eq a, Num a, CharParsing m, Monad m) => m a
hexadecimal :: m a
hexadecimal = do
  m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
"0x" m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
"0X")
  String
contents <- m Char -> m String
forall (m :: * -> *). CharParsing m => m Char -> m String
withUnder m Char
forall (m :: * -> *). CharParsing m => m Char
hexDigit
  let res :: [(a, String)]
res = ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex String
contents
  case [(a, String)]
res of
    [] -> String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String
"unparsable hex literal " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
contents)
    [(a
x, String
"")] -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [(a, String)]
_ -> String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String
"ambiguous hex literal " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
contents)

-- | Parse a number in octal.
--
-- Requires a @0@, @0o@ or @0O@ prefix. No leading signs are accepted.
-- Accepts @0..7@ and underscore separators.
octal :: forall a m. (Num a, CharParsing m, Monad m) => m a
octal :: m a
octal = do
  m (Maybe Char) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'0' m Char -> m (Maybe Char) -> m (Maybe Char)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"oO"))
  String
digs <- m Char -> m String
forall (m :: * -> *). CharParsing m => m Char -> m String
withUnder m Char
forall (m :: * -> *). CharParsing m => m Char
octDigit
  Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> a) -> m Integer -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m Integer
forall a (m :: * -> *). (Read a, CharParsing m) => String -> m a
attempt @Integer (String
"0o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
digs)

-- | Parse a number in binary.
--
-- Requires a @0b@ or @0B@ prefix. No leading signs are accepted.
-- Accepts @0@, @1@, and underscore separators.
binary :: forall a m. (Show a, Num a, CharParsing m, Monad m) => m a
binary :: m a
binary = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'0')
  m (Maybe Char) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"bB"))
  String
digs <- m Char -> m String
forall (m :: * -> *). CharParsing m => m Char -> m String
withUnder (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"01")
  let c2b :: Char -> p
c2b Char
c = case Char
c of
        Char
'0' -> p
0
        Char
'1' -> p
1
        Char
x -> String -> p
forall a. HasCallStack => String -> a
error (String
"Invariant violated: both Attoparsec and readInt let a bad digit through: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
x])
  let res :: [(a, String)]
res = a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt a
2 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"01") Char -> Int
forall p. Num p => Char -> p
c2b String
digs
  case [(a, String)]
res of
    [] -> String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String
"No parse of binary literal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
digs)
    [(a
x, String
"")] -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [(a, String)]
others -> String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String
"Too many parses of binary literal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(a, String)] -> String
forall a. Show a => a -> String
show [(a, String)]
others)

-- | Parse an arbitrary-precision number with an optional decimal part.
--
-- Unlike 'scientificP' or Scientific's 'Read' instance, this handles:
--
--   * omitted whole parts, e.g. @.5@
--   * omitted decimal parts, e.g. @5.@
--   * exponential notation, e.g. @3.14e+1@
--   * numeric parts, in whole or decimal or exponent parts, with @_@ characters
--   * hexadecimal, octal, and binary integer literals, without a decimal part.
--
-- You may either omit the whole or the leading part, not both; this parser also rejects the empty string.
-- It does /not/ handle hexadecimal floating-point numbers.
floating :: (CharParsing m, Monad m) => m Scientific
floating :: m Scientific
floating = m Scientific -> m Scientific
forall a (m :: * -> *). (CharParsing m, Num a) => m a -> m a
signed ([m Scientific] -> m Scientific
forall (m :: * -> *) a. Alternative m => [m a] -> m a
choice [m Scientific
forall a (m :: * -> *).
(Eq a, Num a, CharParsing m, Monad m) =>
m a
hexadecimal, m Scientific
forall a (m :: * -> *). (Num a, CharParsing m, Monad m) => m a
octal, m Scientific
forall a (m :: * -> *).
(Show a, Num a, CharParsing m, Monad m) =>
m a
binary, m Scientific
dec])
  where
    -- Compared to the binary parser, this is positively breezy.
    dec :: m Scientific
dec = do
      -- Try getting the whole part of a floating literal.
      String
leadings <- String -> String
stripUnder (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (m Char
forall (m :: * -> *). CharParsing m => m Char
digit m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'_')
      -- Try reading a dot.
      m (Maybe Char) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'.'))
      -- The trailing part...
      String
trailings <- String -> String
stripUnder (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (m Char
forall (m :: * -> *). CharParsing m => m Char
digit m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'_')
      -- ...and the exponent.
      String
exponent <- String -> String
stripUnder (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"eE_0123456789+-")
      -- Ensure we don't read an empty string, or one consisting only of a dot and/or an exponent.
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
trailings Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
leadings) (String -> m ()
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"Does not accept a single dot")
      -- Replace empty parts with a zero.
      let leads :: String
leads = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
leadings then String
"0" else String
leadings
      let trail :: String
trail = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
trailings then String
"0" else String
trailings
      String -> m Scientific
forall a (m :: * -> *). (Read a, CharParsing m) => String -> m a
attempt (String
leads String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
trail String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
exponent)

-- | Converts a numeric parser to one that accepts an optional leading sign.
signed :: forall a m . (CharParsing m, Num a) => m a -> m a
signed :: m a -> m a
signed m a
p =
  (a -> a
forall a. Num a => a -> a
negate (a -> a) -> m a -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-' m Char -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
p))
    m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' m Char -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
p)
    m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m a
p

-- | Converts a numeric parser to one that accepts a trailing imaginary specifier
-- @i@ or @j@. This does not add facilities for two-valued literals, i.e. @1+4j@,
-- as those are generally best left to high-level expression facilities.
imaginary :: forall a m . (CharParsing m, Monad m, Num a) => m a -> m (Complex a)
imaginary :: m a -> m (Complex a)
imaginary m a
num = do
  a
real <- m a
num
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"ij")
  Complex a -> m (Complex a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
0 a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
real)

stripUnder :: String -> String
stripUnder :: String -> String
stripUnder = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')

attempt :: (Read a, CharParsing m) => String -> m a
attempt :: String -> m a
attempt String
str = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String
"No parse: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str)) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str)

withUnder :: CharParsing m => m Char -> m String
withUnder :: m Char -> m String
withUnder m Char
p = String -> String
stripUnder (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((:) (Char -> String -> String) -> m Char -> m (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
p m (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (m Char
p m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'_'))