summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-07 14:37:58 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-07 18:28:22 +0200
commitbca59ef2624ca1d9c1874db6d6f8e9270db0dfb7 (patch)
treeccd4adc5ac31d10d745d6e551b3748f6fe188483
parent409e9dc95aa9f17770f21d11a65ec839da699f16 (diff)
Number type for arbitrary-precision floating point values
-rw-r--r--src/Parser.hs38
-rw-r--r--src/Test.hs6
2 files changed, 36 insertions, 8 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 22928c3..29583e1 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -12,6 +12,7 @@ import Control.Monad.State
import Data.Char
import Data.Maybe
+import Data.Scientific
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text qualified as T
@@ -141,8 +142,15 @@ stringExpansion tname conv = do
maybe err return $ listToMaybe $ catMaybes $ conv e
-integerLiteral :: TestParser (Expr Integer)
-integerLiteral = Literal . read . TL.unpack <$> takeWhile1P (Just "integer") isDigit
+numberLiteral :: TestParser SomeExpr
+numberLiteral = label "number" $ lexeme $ do
+ x <- L.scientific
+ choice
+ [ return (SomeExpr $ Literal (x / 100)) <* void (char ('%'))
+ , if base10Exponent x == 0
+ then return $ SomeExpr $ Literal (coefficient x)
+ else return $ SomeExpr $ Literal x
+ ]
quotedString :: TestParser (Expr Text)
quotedString = label "string" $ lexeme $ do
@@ -163,6 +171,7 @@ quotedString = label "string" $ lexeme $ do
,do e <- stringExpansion (T.pack "string") $ \e ->
[ cast e
, UnOp (T.pack . show @Integer) <$> cast e
+ , UnOp (T.pack . show @Scientific) <$> cast e
]
(e:) <$> inner
]
@@ -184,6 +193,7 @@ regex = label "regular expression" $ lexeme $ do
[ cast e
, UnOp RegexString <$> cast e
, UnOp (RegexString . T.pack . show @Integer) <$> cast e
+ , UnOp (RegexString . T.pack . show @Scientific) <$> cast e
]
(e:) <$> inner
]
@@ -223,20 +233,32 @@ someExpr = join inner <?> "expression"
table = [ [ recordSelector
]
- , [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
+ , [ prefix "-" $ [ SomeUnOp (negate @Integer)
+ , SomeUnOp (negate @Scientific)
+ ]
]
- , [ binary "*" $ [ SomeBinOp ((*) @Integer) ]
+ , [ binary "*" $ [ SomeBinOp ((*) @Integer)
+ , SomeBinOp ((*) @Scientific)
+ ]
{- TODO: parsing issues with regular expressions
- , binary "/" $ [ SomeBinOp (div @Integer) ]
+ , binary "/" $ [ SomeBinOp (div @Integer)
+ , SomeBinOp ((/) @Scientific)
+ ]
-}
]
- , [ binary "+" $ [ SomeBinOp ((+) @Integer) ]
- , binary "-" $ [ SomeBinOp ((-) @Integer) ]
+ , [ binary "+" $ [ SomeBinOp ((+) @Integer)
+ , SomeBinOp ((+) @Scientific)
+ ]
+ , binary "-" $ [ SomeBinOp ((-) @Integer)
+ , SomeBinOp ((-) @Scientific)
+ ]
]
, [ binary "==" $ [ SomeBinOp ((==) @Integer)
+ , SomeBinOp ((==) @Scientific)
, SomeBinOp ((==) @Text)
]
, binary "/=" $ [ SomeBinOp ((/=) @Integer)
+ , SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
]
]
@@ -278,7 +300,7 @@ someExpr = join inner <?> "expression"
applyRecordSelector e (RecordSelector f) = SomeExpr $ UnOp f e
literal = label "literal" $ choice
- [ return . SomeExpr <$> integerLiteral
+ [ return <$> numberLiteral
, return . SomeExpr <$> quotedString
, return . SomeExpr <$> regex
]
diff --git a/src/Test.hs b/src/Test.hs
index cfc144b..ab7e125 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -15,6 +15,7 @@ module Test (
import Data.Char
import Data.List
+import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
@@ -71,6 +72,11 @@ instance ExprType Integer where
textExprValue x = T.pack (show x)
emptyVarValue = 0
+instance ExprType Scientific where
+ textExprType _ = T.pack "number"
+ textExprValue x = T.pack (show x)
+ emptyVarValue = 0
+
instance ExprType Bool where
textExprType _ = T.pack "bool"
textExprValue True = T.pack "true"