diff --git a/HsYAML.cabal b/HsYAML.cabal index d1a0da3..add01bc 100644 --- a/HsYAML.cabal +++ b/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.* diff --git a/cabal.project b/cabal.project index ab0cf99..65c2b74 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ packages: . package HsYAML - flags: +exe + flags: +exe \ No newline at end of file diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs index ccd7a41..86512b6 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..42fa5d2 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 '+') @@ -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 -- 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