Encode doubles as Double, do bounds checks, and add support for NaN and Infinity values (#667)

dhall-json/src/Dhall/JSON.hs

@@ -239,7 +239,10 @@ dhallToJSON e0 = loop (Dhall.Core.normalize e0)
         Dhall.Core.BoolLit a -> return (toJSON a)
         Dhall.Core.NaturalLit a -> return (toJSON a)
         Dhall.Core.IntegerLit a -> return (toJSON a)
-        Dhall.Core.DoubleLit a -> return (toJSON a)
+        Dhall.Core.DoubleLit a
+          | isInfinite a && a > 0 -> return (toJSON ( 1.7976931348623157e308 :: Double))
+          | isInfinite a && a < 0 -> return (toJSON (-1.7976931348623157e308 :: Double))
+          | otherwise -> return (toJSON a)
         Dhall.Core.TextLit (Dhall.Core.Chunks [] a) -> do
             return (toJSON a)
         Dhall.Core.ListLit _ a -> do

dhall/src/Dhall.hs

@@ -616,16 +616,11 @@ integer = Type {..}
 
 {-| Decode a `Scientific`
 
->>> input scientific "1e1000000000"
-1.0e1000000000
+>>> input scientific "1e100"
+1.0e100
 -}
 scientific :: Type Scientific
-scientific = Type {..}
-  where
-    extract (DoubleLit n) = pure n
-    extract  _            = empty
-
-    expected = Double
+scientific = fmap Data.Scientific.fromFloatDigits double
 
 {-| Decode a `Double`
 
@@ -633,7 +628,12 @@ scientific = Type {..}
 42.0
 -}
 double :: Type Double
-double = fmap Data.Scientific.toRealFloat scientific
+double = Type {..}
+  where
+    extract (DoubleLit n) = pure n
+    extract  _            = empty
+
+    expected = Double
 
 {-| Decode lazy `Text`
 
@@ -1103,17 +1103,13 @@ instance Inject Word64 where
 
         declared = Integer
 
-instance Inject Scientific where
+instance Inject Double where
     injectWith _ = InputType {..}
       where
         embed = DoubleLit
 
         declared = Double
 
-instance Inject Double where
-    injectWith =
-        fmap (contramap (Data.Scientific.fromFloatDigits :: Double -> Scientific)) injectWith
-
 instance Inject () where
     injectWith _ = InputType {..}
       where

dhall/src/Dhall/Binary.hs

@@ -45,8 +45,9 @@ import Data.Monoid ((<>))
 import Data.Text (Text)
 import Options.Applicative (Parser)
 import Prelude hiding (exponent)
+import GHC.Float (double2Float, float2Double)
+import Codec.CBOR.Magic (floatToWord16, wordToFloat16)
 
-import qualified Data.Scientific
 import qualified Data.Sequence
 import qualified Data.Text
 import qualified Dhall.Map
@@ -334,14 +335,17 @@ encode (NaturalLit n) =
     TList [ TInt 15, TInteger (fromIntegral n) ]
 encode (IntegerLit n) =
     TList [ TInt 16, TInteger n ]
-encode (DoubleLit n) =
-    TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]
+encode (DoubleLit n64)
+    -- cborg always encodes NaN as "7e00"
+    | isNaN n64 = THalf n32
+    | useHalf   = THalf n32
+    | useFloat  = TFloat n32
+    | otherwise = TDouble n64
   where
-    normalized = Data.Scientific.normalize n
-
-    exponent = Data.Scientific.base10Exponent normalized
-
-    mantissa = Data.Scientific.coefficient normalized
+    n32      = double2Float n64
+    n16      = floatToWord16 n32
+    useFloat = n64 == float2Double n32
+    useHalf  = n64 == (float2Double . wordToFloat16 . fromIntegral) n16
 encode (TextLit (Chunks xys₀ z₀)) =
     TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ])
   where
@@ -636,10 +640,12 @@ decode (TList [ TInt 16, TInt n ]) = do
     return (IntegerLit (fromIntegral n))
 decode (TList [ TInt 16, TInteger n ]) = do
     return (IntegerLit n)
-decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]) = do
-    return (DoubleLit (Data.Scientific.scientific mantissa exponent))
-decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInt mantissa ]) ]) = do
-    return (DoubleLit (Data.Scientific.scientific (fromIntegral mantissa) exponent))
+decode (THalf n) = do
+    return (DoubleLit (float2Double n))
+decode (TFloat n) = do
+    return (DoubleLit (float2Double n))
+decode (TDouble n) = do
+    return (DoubleLit n)
 decode (TList (TInt 18 : xs)) = do
     let process (TString x : y₁ : zs) = do
             y₀ <- decode y₁

dhall/src/Dhall/Core.hs

@@ -72,7 +72,6 @@ import Data.Functor.Identity (Identity(..))
 import Data.HashSet (HashSet)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.String (IsString(..))
-import Data.Scientific (Scientific)
 import Data.Semigroup (Semigroup(..))
 import Data.Sequence (Seq, ViewL(..), ViewR(..))
 import Data.Text (Text)
@@ -385,7 +384,7 @@ data Expr s a
     -- | > Double                                   ~  Double
     | Double
     -- | > DoubleLit n                              ~  n
-    | DoubleLit Scientific
+    | DoubleLit Double
     -- | > DoubleShow                               ~  Double/show
     | DoubleShow
     -- | > Text                                     ~  Text
@@ -1620,7 +1619,8 @@ normalizeWithM ctx e0 = loop (denote e0)
                     App IntegerShow (IntegerLit n)
                         | 0 <= n    -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n))))
                         | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n))))
-                    App IntegerToDouble (IntegerLit n) -> pure (DoubleLit (fromInteger n))
+                    -- `(read . show)` is used instead of `fromInteger` because `read` uses the correct rounding rule
+                    App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((read . show) n))
                     App DoubleShow (DoubleLit n) ->
                         pure (TextLit (Chunks [] (Data.Text.pack (show n))))
                     App (App OptionalBuild _A₀) g ->
@@ -2256,6 +2256,8 @@ reservedIdentifiers =
         , "None"
         , "Optional/build"
         , "Optional/fold"
+        , "NaN"
+        , "Infinity"
         ]
 
 

dhall/src/Dhall/Diff.hs

@@ -19,7 +19,6 @@ import Data.Foldable (fold, toList)
 import Data.Function (on)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Monoid (Any(..))
-import Data.Scientific (Scientific)
 import Data.Semigroup
 import Data.Sequence (Seq)
 import Data.String (IsString(..))
@@ -190,8 +189,8 @@ diffLabels ksL ksR =
 diffNatural :: Natural -> Natural -> Diff
 diffNatural = diffPrimitive (token . Internal.prettyNatural)
 
-diffScientific :: Scientific -> Scientific -> Diff
-diffScientific = diffPrimitive (token . Internal.prettyScientific)
+diffDouble :: Double -> Double -> Diff
+diffDouble = diffPrimitive (token . Internal.prettyDouble)
 
 diffConst :: Const -> Const -> Diff
 diffConst = diffPrimitive (token . Internal.prettyConst)
@@ -1247,7 +1246,7 @@ diffPrimitiveExpression l@(NaturalLit {}) r =
 diffPrimitiveExpression l r@(NaturalLit {}) =
     mismatch l r
 diffPrimitiveExpression (DoubleLit aL) (DoubleLit aR) =
-    diffScientific aL aR
+    diffDouble aL aR
 diffPrimitiveExpression l@(DoubleLit {}) r =
     mismatch l r
 diffPrimitiveExpression l r@(DoubleLit {}) =

dhall/src/Dhall/Parser/Expression.hs

@@ -230,6 +230,7 @@ completeExpression embedded = completeExpression_
                     , alternative06
                     , alternative07
                     , alternative37
+                    , alternative09
 
                     , builtin <?> "built-in expression"
                     ]
@@ -237,8 +238,12 @@ completeExpression embedded = completeExpression_
             <|> alternative38
           where
             alternative00 = do
+                n <- Text.Megaparsec.getOffset
                 a <- try doubleLiteral
-                return (DoubleLit a)
+                b <- if isInfinite a
+                       then Text.Megaparsec.setOffset n *> fail "double out of bounds"
+                       else return a
+                return (DoubleLit b)
 
             alternative01 = do
                 a <- try naturalLiteral
@@ -270,6 +275,10 @@ completeExpression embedded = completeExpression_
                 b <- importExpression
                 return (Merge a b Nothing)
 
+            alternative09 = do
+                a <- try doubleInfinity
+                return (DoubleLit a)
+
             builtin = do
                 let predicate c =
                             c == 'N'
@@ -283,6 +292,8 @@ completeExpression embedded = completeExpression_
                         ||  c == 'F'
                         ||  c == 'K'
 
+                let nan = (0.0/0.0)
+
                 c <- Text.Megaparsec.lookAhead (Text.Megaparsec.satisfy predicate)
 
                 case c of
@@ -298,6 +309,7 @@ completeExpression embedded = completeExpression_
                             , NaturalShow      <$ _NaturalShow
                             , Natural          <$ _Natural
                             , None             <$ _None
+                            , DoubleLit nan    <$ _NaN
                             ]
                     'I' ->
                         choice

dhall/src/Dhall/Parser/Token.hs

@@ -14,6 +14,7 @@ module Dhall.Parser.Token (
     identifier,
     hexNumber,
     doubleLiteral,
+    doubleInfinity,
     naturalLiteral,
     integerLiteral,
     _Optional,
@@ -55,6 +56,7 @@ module Dhall.Parser.Token (
     _List,
     _True,
     _False,
+    _NaN,
     _Type,
     _Kind,
     _Sort,
@@ -110,7 +112,6 @@ import qualified Dhall.Set
 import qualified Text.Parser.Char
 import qualified Text.Parser.Combinators
 
-import Data.Scientific (Scientific)
 import Numeric.Natural (Natural)
 import Prelude hiding (const, pi)
 
@@ -135,18 +136,28 @@ hexdig c =
     ||  ('A' <= c && c <= 'F')
     ||  ('a' <= c && c <= 'f')
 
-doubleLiteral :: Parser Scientific
+signPrefix :: Num a => Parser (a -> a)
+signPrefix = (do
+    let positive = fmap (\_ -> id    ) (Text.Parser.Char.char '+')
+    let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-')
+    positive <|> negative ) <?> "sign"
+
+doubleLiteral :: Parser Double
 doubleLiteral = (do
-    sign <-  fmap (\_ -> negate) (Text.Parser.Char.char '-')
-         <|> pure id
-    a    <-  Text.Parser.Token.scientific
+    sign <- signPrefix <|> pure id
+    a <- Text.Parser.Token.double
     return (sign a) ) <?> "double literal"
 
+doubleInfinity :: Parser Double
+doubleInfinity = (do
+    let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-')
+    sign <- negative <|> pure id
+    a <- Text.Parser.Char.text "Infinity" >> whitespace >> return (1.0/0.0)
+    return (sign a) ) <?> "double infinity"
+
 integerLiteral :: Parser Integer
 integerLiteral = (do
-    let positive = fmap (\_ -> id    ) (Text.Parser.Char.char '+')
-    let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-')
-    sign <- positive <|> negative
+    sign <- signPrefix
     a <- Text.Parser.Token.natural
     return (sign a) ) <?> "integer literal"
 
@@ -618,6 +629,9 @@ _True = reserved "True"
 _False :: Parser ()
 _False = reserved "False"
 
+_NaN :: Parser ()
+_NaN = reserved "NaN"
+
 _Type :: Parser ()
 _Type = reserved "Type"
 

dhall/src/Dhall/Pretty/Internal.hs

@@ -23,7 +23,7 @@ module Dhall.Pretty.Internal (
     , prettyLabels
     , prettyNatural
     , prettyNumber
-    , prettyScientific
+    , prettyDouble
     , prettyToStrictText
     , prettyToString
 
@@ -61,7 +61,6 @@ import Control.Applicative (Applicative(..), (<$>))
 #endif
 import Data.Foldable
 import Data.Monoid ((<>))
-import Data.Scientific (Scientific)
 import Data.Text (Text)
 import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
 import Dhall.Map (Map)
@@ -306,8 +305,8 @@ prettyNumber = literal . Pretty.pretty
 prettyNatural :: Natural -> Doc Ann
 prettyNatural = literal . Pretty.pretty
 
-prettyScientific :: Scientific -> Doc Ann
-prettyScientific = literal . Pretty.pretty . show
+prettyDouble :: Double -> Doc Ann
+prettyDouble = literal . Pretty.pretty
 
 prettyConst :: Const -> Doc Ann
 prettyConst Type = builtin "Type"
@@ -786,7 +785,7 @@ prettyCharacterSet characterSet = prettyExpression
     prettyPrimitiveExpression (NaturalLit a) =
         prettyNatural a
     prettyPrimitiveExpression (DoubleLit a) =
-        prettyScientific a
+        prettyDouble a
     prettyPrimitiveExpression (TextLit a) =
         prettyChunks a
     prettyPrimitiveExpression (Record a) =

dhall/tests/Format.hs

@@ -44,6 +44,10 @@ formatTests =
             Unicode
             "correctly handle scientific notation with a large exponent"
             "largeExponent"
+        , should
+            Unicode
+            "round a double to the nearest representable value. Ties go to even least significant bit"
+            "doubleRound"
         , should
             Unicode
             "correctly format the empty record literal"

dhall/tests/Normalization.hs

@@ -203,6 +203,7 @@ conversions =
         , shouldNormalize "Integer/show" "success/simple/integerShow"
         , shouldNormalize "Double/show"  "success/simple/doubleShow"
         , shouldNormalize "Natural/toInteger" "success/simple/naturalToInteger"
+        , shouldNormalize "Integer/toDouble" "success/simple/integerToDouble"
         ]
 
 customization :: TestTree

dhall/tests/Parser.hs

@@ -149,6 +149,12 @@ parserTests =
         , shouldParse
             "Sort"
             "./tests/parser/success/sort"
+        , shouldNotParse
+            "positive double out of bounds"
+            "./tests/parser/failure/doubleBoundsPos.dhall"
+        , shouldNotParse
+            "negative double out of bounds"
+            "./tests/parser/failure/doubleBoundsNeg.dhall"
         ]
 
 shouldParse :: Text -> FilePath -> TestTree

dhall/tests/format/doubleRoundA.dhall

@@ -0,0 +1,41 @@
+[ 1.0000000000000000
+, 1.0000000000000001
+, 1.0000000000000002
+, 1.0000000000000003
+, 1.0000000000000004
+, 1.0000000000000005
+, 1.0000000000000006
+, 1.0000000000000007
+, 1.0000000000000008
+, 1.0000000000000009
+
+, 1.0000000000000000e64
+, 1.0000000000000001e64
+, 1.0000000000000002e64
+, 1.0000000000000003e64
+, 1.0000000000000004e64
+, 1.0000000000000005e64
+, 1.0000000000000006e64
+, 1.0000000000000007e64
+, 1.0000000000000008e64
+, 1.0000000000000009e64
+
+, 1.0000000000000000e100
+, 1.0000000000000001e100
+, 1.0000000000000002e100
+, 1.0000000000000003e100
+, 1.0000000000000004e100
+, 1.0000000000000005e100
+, 1.0000000000000006e100
+, 1.0000000000000007e100
+, 1.0000000000000008e100
+, 1.0000000000000009e100
+
+, 179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791.0
+, 179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945.0
+, 179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944.0
+
+, -179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791.0
+, -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945.0
+, -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944.0
+]

dhall/tests/format/doubleRoundB.dhall

@@ -0,0 +1,37 @@
+[ 1.0
+, 1.0
+, 1.0000000000000002
+, 1.0000000000000002
+, 1.0000000000000004
+, 1.0000000000000004
+, 1.0000000000000007
+, 1.0000000000000007
+, 1.0000000000000009
+, 1.0000000000000009
+, 1.0e64
+, 1.0000000000000002e64
+, 1.0000000000000002e64
+, 1.0000000000000003e64
+, 1.0000000000000005e64
+, 1.0000000000000005e64
+, 1.0000000000000006e64
+, 1.0000000000000008e64
+, 1.0000000000000008e64
+, 1.0000000000000009e64
+, 1.0e100
+, 1.0e100
+, 1.0000000000000002e100
+, 1.0000000000000002e100
+, 1.0000000000000004e100
+, 1.0000000000000004e100
+, 1.0000000000000006e100
+, 1.0000000000000008e100
+, 1.0000000000000008e100
+, 1.000000000000001e100
+, 1.7976931348623157e308
+, 1.7976931348623157e308
+, 1.7976931348623155e308
+, -1.7976931348623157e308
+, -1.7976931348623157e308
+, -1.7976931348623155e308
+]

dhall/tests/format/largeExponentA.dhall

@@ -1 +1 @@
-[ 1.0, 1e1000000000, 1e-1000000000 ]
+[ 1.0, 1e100, 1e-100 ]

dhall/tests/format/largeExponentB.dhall

@@ -1 +1 @@
-[ 1.0, 1.0e1000000000, 1.0e-1000000000 ]
+[ 1.0, 1.0e100, 1.0e-100 ]

dhall/tests/normalization/success/simple/integerToDoubleA.dhall

@@ -0,0 +1,10 @@
+[ Integer/toDouble +179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497792
+, Integer/toDouble +179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791
+, Integer/toDouble +179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945
+, Integer/toDouble +179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944
+
+, Integer/toDouble -179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497792
+, Integer/toDouble -179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791
+, Integer/toDouble -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945
+, Integer/toDouble -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944
+]

dhall/tests/normalization/success/simple/integerToDoubleB.dhall

@@ -0,0 +1,9 @@
+[ Infinity
+, 1.7976931348623157e308
+, 1.7976931348623157e308
+, 1.7976931348623155e308
+, -Infinity
+, -1.7976931348623157e308
+, -1.7976931348623157e308
+, -1.7976931348623155e308
+]

dhall/tests/parser/failure/doubleBoundsNeg.dhall

@@ -0,0 +1 @@
+-179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497792.0

dhall/tests/parser/failure/doubleBoundsPos.dhall

@@ -0,0 +1 @@
+179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497792.0