From 5a93c4c23d70006f73449b2c158007262c1da33f Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Sun, 12 Dec 2021 14:14:19 -0500 Subject: [PATCH 1/2] Use scientific to fix floating point rounding problems --- HsYAML.cabal | 1 + cabal.project | 4 ---- src/Data/YAML.hs | 8 ++++---- src/Data/YAML/Dumper.hs | 1 - src/Data/YAML/Internal.hs | 1 - src/Data/YAML/Schema.hs | 1 - src/Data/YAML/Schema/Internal.hs | 22 +++++++++++----------- 7 files changed, 16 insertions(+), 22 deletions(-) delete mode 100644 cabal.project diff --git a/HsYAML.cabal b/HsYAML.cabal index 3ef97d5..f9206b3 100644 --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -96,6 +96,7 @@ library , text >=1.2.3 && <1.3 , mtl >=2.2.1 && <2.3 , parsec >=3.1.13.0 && < 3.2 + , scientific >=0.3 && <0.4 -- for GHC.Generics if impl(ghc < 7.6) diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 65c2b74..0000000 --- a/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: . - -package HsYAML - flags: +exe \ No newline at end of file diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs index 2a03dde..a8523f2 100644 --- a/src/Data/YAML.hs +++ b/src/Data/YAML.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Safe #-} -- | -- Copyright: © Herbert Valerio Riedel 2015-2018 @@ -103,6 +102,7 @@ import qualified Control.Monad.Fail as Fail import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L import qualified Data.Map as Map +import Data.Scientific import qualified Data.Text as T import Data.YAML.Dumper @@ -473,11 +473,11 @@ instance FromYAML Word32 where parseYAML = parseInt "Word32" instance FromYAML Word64 where parseYAML = parseInt "Word64" -instance FromYAML Double where +instance FromYAML Scientific where parseYAML = withFloat "!!float" pure -- | Operate on @tag:yaml.org,2002:float@ node (or fail) -withFloat :: String -> (Double -> Parser a) -> Node Pos -> Parser a +withFloat :: String -> (Scientific -> Parser a) -> Node Pos -> Parser a withFloat _ f (Scalar pos (SFloat b)) = fixupFailPos pos (f b) withFloat expected _ v = typeMismatch expected v @@ -679,7 +679,7 @@ instance Loc loc => ToYAML (Node loc) where instance ToYAML Bool where toYAML = Scalar () . SBool -instance ToYAML Double where +instance ToYAML Scientific where toYAML = Scalar () . SFloat instance ToYAML Int where toYAML = Scalar () . SInt . toInteger diff --git a/src/Data/YAML/Dumper.hs b/src/Data/YAML/Dumper.hs index c3ea90d..3e0bc74 100644 --- a/src/Data/YAML/Dumper.hs +++ b/src/Data/YAML/Dumper.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Safe #-} -- | -- Copyright: © Herbert Valerio Riedel 2015-2018 diff --git a/src/Data/YAML/Internal.hs b/src/Data/YAML/Internal.hs index b91ff20..36b459f 100644 --- a/src/Data/YAML/Internal.hs +++ b/src/Data/YAML/Internal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Safe #-} -- | -- Copyright: © Herbert Valerio Riedel 2015-2018 diff --git a/src/Data/YAML/Schema.hs b/src/Data/YAML/Schema.hs index 82cf998..394c1ee 100644 --- a/src/Data/YAML/Schema.hs +++ b/src/Data/YAML/Schema.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | diff --git a/src/Data/YAML/Schema/Internal.hs b/src/Data/YAML/Schema/Internal.hs index 22eeb3e..03704fc 100644 --- a/src/Data/YAML/Schema/Internal.hs +++ b/src/Data/YAML/Schema/Internal.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -31,6 +30,7 @@ module Data.YAML.Schema.Internal import qualified Data.Char as C import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Scientific import qualified Data.Text as T import Numeric (readHex, readOct) import Text.Parsec as P @@ -42,11 +42,11 @@ import qualified Data.YAML.Event as YE import Util -- | Primitive scalar types as defined in YAML 1.2 -data Scalar = SNull -- ^ @tag:yaml.org,2002:null@ - | SBool !Bool -- ^ @tag:yaml.org,2002:bool@ - | SFloat !Double -- ^ @tag:yaml.org,2002:float@ - | SInt !Integer -- ^ @tag:yaml.org,2002:int@ - | SStr !Text -- ^ @tag:yaml.org,2002:str@ +data Scalar = SNull -- ^ @tag:yaml.org,2002:null@ + | SBool !Bool -- ^ @tag:yaml.org,2002:bool@ + | SFloat !Scientific -- ^ @tag:yaml.org,2002:float@ + | SInt !Integer -- ^ @tag:yaml.org,2002:int@ + | SStr !Text -- ^ @tag:yaml.org,2002:str@ | SUnknown !Tag !Text -- ^ unknown/unsupported tag or untagged (thus unresolved) scalar deriving (Eq,Ord,Show,Generic) @@ -271,10 +271,10 @@ coreDecodeInt t -- -- > -? ( 0 | [1-9] [0-9]* ) ( \. [0-9]* )? ( [eE] [-+]? [0-9]+ )? -- -jsonDecodeFloat :: T.Text -> Maybe Double +jsonDecodeFloat :: T.Text -> Maybe Scientific jsonDecodeFloat = either (const Nothing) Just . parse float "" where - float :: Parser Double + float :: Parser Scientific float = do -- -? p0 <- option "" ("-" <$ char '-') @@ -306,12 +306,12 @@ jsonDecodeFloat = either (const Nothing) Just . parse float "" -- -- > [-+]? ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) ( [eE] [-+]? [0-9]+ )? -- -coreDecodeFloat :: T.Text -> Maybe Double +coreDecodeFloat :: T.Text -> Maybe Scientific coreDecodeFloat t | Just j <- Map.lookup t literals = Just j -- short-cut | otherwise = either (const Nothing) Just . parse float "" $ t where - float :: Parser Double + float :: Parser Scientific float = do -- [-+]? p0 <- option "" (("-" <$ char '-') P.<|> "" <$ char '+') @@ -452,7 +452,7 @@ encodeBool b = if b then "true" else "false" -- | Encode Double -- -- @since 0.2.0 -encodeDouble :: Double -> T.Text +encodeDouble :: Scientific -> T.Text encodeDouble d | d /= d = ".nan" | d == (1/0) = ".inf" From cf1c30fa6b3cd1842ba5a9efd341d03b13f96f99 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Fri, 28 Oct 2022 02:26:47 -0400 Subject: [PATCH 2/2] Fix test suite --- HsYAML.cabal | 1 + src/Data/YAML/Schema/Internal.hs | 8 ++----- tests/Tests.hs | 38 +++++++++++--------------------- 3 files changed, 16 insertions(+), 31 deletions(-) diff --git a/HsYAML.cabal b/HsYAML.cabal index f9206b3..c5049b4 100644 --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -152,5 +152,6 @@ test-suite tests , mtl -- non-inherited , QuickCheck == 2.14.* + , scientific , tasty == 1.4.* , tasty-quickcheck == 0.10.* diff --git a/src/Data/YAML/Schema/Internal.hs b/src/Data/YAML/Schema/Internal.hs index 03704fc..42fa5d2 100644 --- a/src/Data/YAML/Schema/Internal.hs +++ b/src/Data/YAML/Schema/Internal.hs @@ -449,15 +449,11 @@ coreSchemaEncoder = SchemaEncoder{..} encodeBool :: Bool -> T.Text encodeBool b = if b then "true" else "false" --- | Encode Double +-- | Encode Scientific -- -- @since 0.2.0 encodeDouble :: Scientific -> T.Text -encodeDouble d - | d /= d = ".nan" - | d == (1/0) = ".inf" - | d == (-1/0) = "-.inf" - | otherwise = T.pack . show $ d +encodeDouble d = T.pack . show $ d -- | Encode Integer -- diff --git a/tests/Tests.hs b/tests/Tests.hs index 40ca8d1..2a28ce3 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ import Control.Monad import Control.Applicative +import Data.Scientific import Data.YAML as Y import qualified Data.Text as T import qualified Data.Map as Map @@ -21,27 +22,12 @@ roundTripBool b | b = "true" == outputStr b | otherwise = "false" == outputStr b -roundTripDouble :: Double -> Double -> Bool -roundTripDouble num denom - | d /= d = ".nan" == outputStr d - | d == (1/0) = ".inf" == outputStr d - | d == (-1/0) = "-.inf" == outputStr d - | otherwise = BS.L.pack (show d) == outputStr d - where d = num / denom - roundTrip :: (Eq a, FromYAML a, ToYAML a) => (a -> a -> Bool) -> a -> a -> Bool roundTrip eq _ v = case decode1 (encode1 v) :: (FromYAML a) => (Either (Pos, String) a) of Left _ -> False Right ans -> ans `eq` v -approxEq :: Double -> Double -> Bool -approxEq a b = a == b || d < maxAbsoluteError || d / max (abs b) (abs a) <= maxRelativeError - where - d = abs (a - b) - maxAbsoluteError = 1e-15 - maxRelativeError = 1e-15 - roundTripEq :: (Eq a, FromYAML a, ToYAML a) => a -> a -> Bool roundTripEq x y = roundTrip (==) x y @@ -53,20 +39,22 @@ tests = [ testGroup "encode" [ testProperty "encodeInt" roundTripInt , testProperty "encodeBool" roundTripBool - , testProperty "encodeDouble" roundTripDouble ] , testGroup "roundTrip" - [ testProperty "Bool" $ roundTripEq True - , testProperty "Double" $ roundTrip approxEq (1::Double) - , testProperty "Int" $ roundTripEq (1::Int) - , testProperty "Integer" $ roundTripEq (1::Integer) - , testProperty "Text" $ roundTripEq T.empty - , testProperty "Seq" $ roundTripEq ([""]:: [T.Text]) - , testProperty "Map" $ roundTripEq (undefined :: Map.Map T.Text T.Text) - , testProperty "Foo" $ roundTripEq (undefined :: Foo) + [ testProperty "Bool" $ roundTripEq True + , testProperty "Int" $ roundTripEq (1::Int) + , testProperty "Integer" $ roundTripEq (1::Integer) + , testProperty "Scientific" $ roundTripEq (1::Scientific) + , testProperty "Text" $ roundTripEq T.empty + , testProperty "Seq" $ roundTripEq ([""]:: [T.Text]) + , testProperty "Map" $ roundTripEq (undefined :: Map.Map T.Text T.Text) + , testProperty "Foo" $ roundTripEq (undefined :: Foo) ] ] +instance Arbitrary Scientific where + arbitrary = scientific <$> arbitrary <*> arbitrary + instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary @@ -95,4 +83,4 @@ instance FromYAML Foo where <*> m .: "fooMap" instance Arbitrary Foo where - arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary \ No newline at end of file + arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary