Use Scientific to fix floating point rounding problems

HsYAML.cabal

@@ -99,6 +99,7 @@ library
                      , text         >= 1.2.3    && < 2.1
                      , mtl          >= 2.2.1    && < 2.4
                      , parsec       >= 3.1.13.0 && < 3.2
+                     , scientific   >= 0.3      && < 0.4
                      , transformers >= 0.4      && < 0.7
 
   -- for GHC.Generics
@@ -155,5 +156,6 @@ test-suite tests
                  , mtl
                    -- non-inherited
                  , QuickCheck == 2.14.*
+                 , scientific
                  , tasty == 1.4.*
                  , tasty-quickcheck == 0.10.*

cabal.project

@@ -1,4 +1,4 @@
 packages: .
 
 package HsYAML
-  flags: +exe
+  flags: +exe

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

src/Data/YAML/Dumper.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE Safe              #-}
 
 -- |
 -- Copyright: © Herbert Valerio Riedel 2015-2018

src/Data/YAML/Internal.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE Safe          #-}
 
 -- |
 -- Copyright: © Herbert Valerio Riedel 2015-2018

src/Data/YAML/Schema.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE Safe                #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- |

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 '+')
@@ -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 :: Double -> T.Text
-encodeDouble d
-  | d /= d      = ".nan"
-  | d == (1/0)  = ".inf"
-  | d == (-1/0) = "-.inf"
-  | otherwise   = T.pack . show $ d
+encodeDouble :: Scientific -> T.Text
+encodeDouble d = T.pack . show $ d
 
 -- | Encode Integer
 --

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
+  arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary