{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
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 ()
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 -> 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)
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"
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
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
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
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
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
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)
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
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
')'