{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- A module that exports two functions, 'parse' and 'parse'',
-- to help with turning text into expression trees.
module Data.SigFig.Parse
  ( parse,
    parse',
  )
where

import Control.Monad (when)
import Data.Bifunctor (first)
import Data.BigDecimal (BigDecimal (BigDecimal))
import Data.BigDecimal qualified as BD
import Data.Foldable (foldr')
import Data.SigFig.Types
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Real (Ratio ((:%)), (%))
import Text.Parsec hiding (parse)
import Text.Parsec qualified as P
import Prelude hiding (exponent)

type Parses = Parsec Text ()

-- | Represents signs.
data Sign = Positive | Negative
  deriving (Int -> Sign -> ShowS
[Sign] -> ShowS
Sign -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sign] -> ShowS
$cshowList :: [Sign] -> ShowS
show :: Sign -> String
$cshow :: Sign -> String
showsPrec :: Int -> Sign -> ShowS
$cshowsPrec :: Int -> Sign -> ShowS
Show, Sign -> Sign -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sign -> Sign -> Bool
$c/= :: Sign -> Sign -> Bool
== :: Sign -> Sign -> Bool
$c== :: Sign -> Sign -> Bool
Eq)

-- | Parse text into either an error message or an expression.
parse :: Text -> Either Text Expr
parse :: Text -> Either Text Expr
parse = forall {c}. Either ParseError c -> Either Text c
textify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse (ParsecT Text () Identity Expr
expr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) String
""
  where
    textify :: Either ParseError c -> Either Text c
textify = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

-- | Like 'parse', but assume the result is a valid expression and crash otherwise.
parse' :: Text -> Expr
parse' :: Text -> Expr
parse' Text
s = case Text -> Either Text Expr
parse Text
s of
  Left Text
e -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"parse' crashed because: " forall a. Semigroup a => a -> a -> a
<> Text
e
  Right Expr
e -> Expr
e

toOp :: Char -> Op
toOp :: Char -> Op
toOp Char
'+' = Op
Add
toOp Char
'-' = Op
Sub
toOp Char
'*' = Op
Mul
toOp Char
'/' = Op
Div
toOp Char
_ = forall a. HasCallStack => String -> a
error String
"should be guarded by parser"

-- | Parse an optional sign preceding a value.
sign :: Parses Sign
sign :: Parses Sign
sign =
  do forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'; forall (m :: * -> *) a. Monad m => a -> m a
return Sign
Negative
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+'; forall (m :: * -> *) a. Monad m => a -> m a
return Sign
Positive
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Sign
Positive

signToFunc :: Num a => Sign -> (a -> a)
signToFunc :: forall a. Num a => Sign -> a -> a
signToFunc Sign
Positive = forall a. a -> a
id
signToFunc Sign
Negative = forall a. Num a => a -> a
negate

-- | Parses at least 1 digit, as Text.
digits :: Parses Text
digits :: Parses Text
digits = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

-- | Get the number of significant figures for a
-- non-negative integer if it was typed as text.
numSigFigsNNIntTextual :: Text -> Integer
numSigFigsNNIntTextual :: Text -> Integer
numSigFigsNNIntTextual Text
t =
  let residue :: Text
residue = (Char -> Bool) -> Text -> Text
T.dropAround (forall a. Eq a => a -> a -> Bool
== Char
'0') Text
t
   in forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
residue then Int
1 else Text -> Int
T.length Text
residue

-- | Get the number of significant figures for a
-- non-negative float if it was typed as text.
numSigFigsNNFltTextual :: Text -> Integer
numSigFigsNNFltTextual :: Text -> Integer
numSigFigsNNFltTextual Text
t =
  let residue :: Text
residue = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'.') forall a b. (a -> b) -> a -> b
$ Text
t
   in forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
residue then Text -> Text -> Int
T.count Text
"0" Text
t else Text -> Int
T.length Text
residue

-- | Parse an integer which may have a sign.
integer :: Parses Term
integer :: Parses Term
integer = do
  Sign
s <- Parses Sign
sign
  Text
digs <- Parses Text
digits
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
Measured (Text -> Integer
numSigFigsNNIntTextual Text
digs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Sign -> a -> a
signToFunc Sign
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BigDecimal
BD.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
digs

-- | Parse a float which may have a sign.
float :: Parses Term
float :: Parses Term
float = do
  Sign
s <- Parses Sign
sign
  Text
ldigs <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Text
"" Parses Text
digits
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
  Text
rdigs <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Text
"" Parses Text
digits
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
ldigs Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
rdigs) (forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected String
"dot without other digits")
  let flt :: Text
flt = Text
ldigs forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
rdigs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
Measured (Text -> Integer
numSigFigsNNFltTextual Text
flt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Sign -> a -> a
signToFunc Sign
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BigDecimal
BD.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
flt

sciNotation :: Parses Term
sciNotation :: Parses Term
sciNotation = do
  Measured Integer
sf coef :: BigDecimal
coef@(BigDecimal Integer
coefValue Natural
coefScale) <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parses Term
float forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parses Term
integer
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'e'
  Measured Integer
_ (BigDecimal Integer
exp Natural
_) <- Parses Term
integer
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> BigDecimal -> Term
Measured Integer
sf forall a b. (a -> b) -> a -> b
$ BigDecimal -> BigDecimal
BD.nf forall a b. (a -> b) -> a -> b
$ BigDecimal
coef forall a. Num a => a -> a -> a
* BigDecimal
10 forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Integer
exp

integerConstant :: Parses Term
integerConstant :: Parses Term
integerConstant = do
  Measured Integer
_ (BigDecimal Integer
v Natural
_) <- Parses Term
integer
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'c'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Term
Constant forall a b. (a -> b) -> a -> b
$ Integer
v forall a. Integral a => a -> a -> Ratio a
% Integer
1

floatConstant :: Parses Term
floatConstant :: Parses Term
floatConstant = do
  Measured Integer
_ (BigDecimal Integer
v Natural
s) <- Parses Term
float
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'c'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Term
Constant forall a b. (a -> b) -> a -> b
$ Integer
v forall a. Integral a => a -> a -> Ratio a
% (Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Natural
s)

sciNotationConstant :: Parses Term
sciNotationConstant :: Parses Term
sciNotationConstant = do
  Measured Integer
_ (BigDecimal Integer
v Natural
s) <- Parses Term
sciNotation
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'c'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Term
Constant forall a b. (a -> b) -> a -> b
$ Integer
v forall a. Integral a => a -> a -> Ratio a
% (Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Natural
s)

literal :: Parses Expr
literal :: ParsecT Text () Identity Expr
literal = do
  Term
l <- forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parses Term
sciNotationConstant, Parses Term
floatConstant, Parses Term
integerConstant, Parses Term
sciNotation, Parses Term
float, Parses Term
integer]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Expr
Literal Term
l

factor :: Parses Expr
factor :: ParsecT Text () Identity Expr
factor = do
  ParsecT Text () Identity Expr
operand forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
`chainl1` forall {u}. ParsecT Text u Identity (Expr -> Expr -> Expr)
operator
  where
    operand :: ParsecT Text () Identity Expr
operand = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall a. Parses a -> Parses a
betweenParens ParsecT Text () Identity Expr
expr, forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () Identity Expr
literal, ParsecT Text () Identity Expr
function] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
    operator :: ParsecT Text u Identity (Expr -> Expr -> Expr)
operator = Expr -> Expr -> Expr
Exp forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"**" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces)

term :: Parses Expr
term :: ParsecT Text () Identity Expr
term = do
  ParsecT Text () Identity Expr
factor ParsecT Text () Identity Expr
-> (Parses Op, Op, [(Op, Expr)] -> Expr)
-> ParsecT Text () Identity Expr
`chainl1'` (forall {u}. ParsecT Text u Identity Op
op, Op
Mul, [(Op, Expr)] -> Expr
Prec2)
  where
    op :: ParsecT Text u Identity Op
op = Char -> Op
toOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"*/" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

expr :: Parses Expr
expr :: ParsecT Text () Identity Expr
expr = do
  ParsecT Text () Identity Expr
term ParsecT Text () Identity Expr
-> (Parses Op, Op, [(Op, Expr)] -> Expr)
-> ParsecT Text () Identity Expr
`chainl1'` (forall {u}. ParsecT Text u Identity Op
op, Op
Add, [(Op, Expr)] -> Expr
Prec1)
  where
    op :: ParsecT Text u Identity Op
op = Char -> Op
toOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"+-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

chainl1' :: Parses Expr -> (Parses Op, Op, [(Op, Expr)] -> Expr) -> Parses Expr
{-# INLINEABLE chainl1' #-}
chainl1' :: ParsecT Text () Identity Expr
-> (Parses Op, Op, [(Op, Expr)] -> Expr)
-> ParsecT Text () Identity Expr
chainl1' ParsecT Text () Identity Expr
p (Parses Op
o, Op
i, [(Op, Expr)] -> Expr
c) = do Expr
x <- ParsecT Text () Identity Expr
p; [(Op, Expr)] -> ParsecT Text () Identity Expr
rest [(Op
i, Expr
x)]
  where
    rest :: [(Op, Expr)] -> ParsecT Text () Identity Expr
rest [(Op, Expr)]
x =
      do
        Op
op <- Parses Op
o
        Expr
y <- ParsecT Text () Identity Expr
p
        [(Op, Expr)] -> ParsecT Text () Identity Expr
rest forall a b. (a -> b) -> a -> b
$ (Op
op, Expr
y) forall a. a -> [a] -> [a]
: [(Op, Expr)]
x
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Op, Expr)]
x forall a. Ord a => a -> a -> Bool
> Int
1 then [(Op, Expr)] -> Expr
c (forall a. [a] -> [a]
reverse [(Op, Expr)]
x) else forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Op, Expr)]
x)

-- ❯ parseEval "344 ** 2 ** 4"
-- Right (Measured {numSigFigs = 3, value = 194000000000000000000})
-- ❯ (344 ^ 2) ^ 4
-- 196095460708571938816

-- | A list of all the functions available.
funcMap :: [(Function, Text)]
funcMap :: [(Function, Text)]
funcMap =
  [ (Function
Log10, Text
"log"),
    (Function
Antilog10, Text
"exp")
  ]

genFuncParsers :: [Parses Expr]
genFuncParsers :: [ParsecT Text () Identity Expr]
genFuncParsers = do
  (Function
f, Text
t) <- [(Function, Text)]
funcMap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
    Expr
e <- ParsecT Text () Identity Expr
expr
    forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Function -> Expr -> Expr
Apply Function
f Expr
e

-- | Parses a function application.
function :: Parses Expr
function :: ParsecT Text () Identity Expr
function = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT Text () Identity Expr]
genFuncParsers

betweenParens :: Parses a -> Parses a
betweenParens :: forall a. Parses a -> Parses a
betweenParens Parses a
p = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parses a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'