ehmry/dhall-haskell
ehmry
/
dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix Expr's Eq instance via a newtype wrapper for Doubles (#1347) 

See the haddocks in Dhall.Core for details.

Fixes #1341.
This commit is contained in:
Simon Jakobi 2019-09-28 16:56:37 +02:00 committed by mergify[bot]
parent 8abb411f06
commit 7c91dd5f48
17 changed files with 131 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
dhall-json/src/Dhall/JSON.hs
View File

@ -188,7 +188,7 @@ import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty)
import Dhall.Core (Binding(..), Expr)
import Dhall.Core (Binding(..), DhallDouble(..), Expr)
import Dhall.Import (SemanticCacheMode(..))
import Dhall.TypeCheck (X)
import Dhall.Map (Map)
@ -386,7 +386,7 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
Core.BoolLit a -> return (toJSON a)
Core.NaturalLit a -> return (toJSON a)
Core.IntegerLit a -> return (toJSON a)
Core.DoubleLit a -> return (toJSON a)
Core.DoubleLit (DhallDouble a) -> return (toJSON a)
Core.TextLit (Core.Chunks [] a) -> do
return (toJSON a)
Core.ListLit _ a -> do
@ -503,7 +503,7 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
ys <- traverse inner (Foldable.toList xs)
return (Aeson.Object (HashMap.fromList ys))
outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit n)) = do
outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) = do
return (Aeson.toJSON n)
outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do
return (toJSON text)
@ -1015,7 +1015,7 @@ handleSpecialDoubles specialDoubleMode =
ForbidWithinJSON -> forbidWithinJSON
ApproximateWithinJSON -> approximateWithinJSON
useYAMLEncoding (Core.DoubleLit n)
useYAMLEncoding (Core.DoubleLit (DhallDouble n))
| isInfinite n && 0 < n =
return (Just (Core.TextLit (Core.Chunks [] "inf")))
| isInfinite n && n < 0 =
@ -1025,17 +1025,17 @@ handleSpecialDoubles specialDoubleMode =
useYAMLEncoding _ =
return Nothing
forbidWithinJSON (Core.DoubleLit n)
forbidWithinJSON (Core.DoubleLit (DhallDouble n))
| isInfinite n || isNaN n =
Left (SpecialDouble n)
forbidWithinJSON _ =
return Nothing
approximateWithinJSON (Core.DoubleLit n)
approximateWithinJSON (Core.DoubleLit (DhallDouble n))
| isInfinite n && n > 0 =
return (Just (Core.DoubleLit ( 1.7976931348623157e308 :: Double)))
return (Just (Core.DoubleLit (DhallDouble 1.7976931348623157e308)))
| isInfinite n && n < 0 =
return (Just (Core.DoubleLit (-1.7976931348623157e308 :: Double)))
return (Just (Core.DoubleLit (DhallDouble (-1.7976931348623157e308))))
-- Do nothing for @NaN@, which already encodes to @null@
approximateWithinJSON _ =
return Nothing

6
dhall-json/src/Dhall/JSONToDhall.hs
View File

@ -237,7 +237,7 @@ import Options.Applicative (Parser)
import Dhall.JSON.Util (pattern V)
import qualified Dhall.Core as D
import Dhall.Core (Expr(App), Chunks(..))
import Dhall.Core (Expr(App), Chunks(..), DhallDouble(..))
import qualified Dhall.Import
import qualified Dhall.Map as Map
import qualified Dhall.Parser
@ -487,7 +487,7 @@ dhallFromJSON (Conversion {..}) expressionType =
-- number ~> Double
loop D.Double (A.Number x)
= Right (D.DoubleLit $ toRealFloat x)
= Right (D.DoubleLit $ DhallDouble $ toRealFloat x)
-- string ~> Text
loop D.Text (A.String t)
@ -551,7 +551,7 @@ dhallFromJSON (Conversion {..}) expressionType =
outer (A.String s) =
D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s))
outer (A.Number n) =
D.App (D.Field "json" "number") (D.DoubleLit (toRealFloat n))
D.App (D.Field "json" "number") (D.DoubleLit (DhallDouble (toRealFloat n)))
outer (A.Bool b) =
D.App (D.Field "json" "bool") (D.BoolLit b)
outer A.Null =

4
dhall-nix/src/Dhall/Nix.hs
View File

@ -96,7 +96,7 @@ import Data.Fix (Fix(..))
import Data.Traversable (for)
import Data.Typeable (Typeable)
import Data.Void (absurd)
import Dhall.Core (Chunks(..), Const(..), Expr(..), MultiLet(..), Var(..))
import Dhall.Core (Chunks(..), Const(..), DhallDouble(..), Expr(..), MultiLet(..), Var(..))
import Dhall.TypeCheck (X)
import Nix.Atoms (NAtom(..))
import Nix.Expr
@ -331,7 +331,7 @@ dhallToNix e = loop (Dhall.Core.normalize e)
loop IntegerToDouble = do
return (Fix (NAbs "x" "x"))
loop Double = return (Fix (NSet []))
loop (DoubleLit n) = return (Fix (NConstant (NFloat (realToFrac n))))
loop (DoubleLit (DhallDouble n)) = return (Fix (NConstant (NFloat (realToFrac n))))
loop DoubleShow = do
return "toString"
loop Text = return (Fix (NSet []))

1
dhall/dhall.cabal
View File

@ -566,6 +566,7 @@ Test-Suite tasty
scientific ,
semigroups ,
serialise ,
special-values < 0.2 ,
spoon < 0.4 ,
tasty >= 0.11.2 && < 1.3 ,
tasty-expected-failure < 0.12,

8
dhall/src/Dhall.hs
View File

@ -126,7 +126,7 @@ import Data.Text.Prettyprint.Doc (Pretty)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import Dhall.Core (Expr(..), Chunks(..))
import Dhall.Core (Expr(..), Chunks(..), DhallDouble(..))
import Dhall.Import (Imported(..))
import Dhall.Parser (Src(..))
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
@ -716,8 +716,8 @@ scientific = fmap Data.Scientific.fromFloatDigits double
double :: Type Double
double = Type {..}
where
extract (DoubleLit n) = pure n
extract expr = typeError Double expr
extract (DoubleLit (DhallDouble n)) = pure n
extract expr = typeError Double expr
expected = Double
@ -1548,7 +1548,7 @@ instance Inject Word64 where
instance Inject Double where
injectWith _ = InputType {..}
where
embed = DoubleLit
embed = DoubleLit . DhallDouble
declared = Double

35
dhall/src/Dhall/Binary.hs
View File

@ -31,6 +31,7 @@ import Dhall.Core
, Chunks(..)
, Const(..)
, Directory(..)
, DhallDouble(..)
, Expr(..)
, File(..)
, FilePrefix(..)
@ -343,18 +344,8 @@ instance ToTerm a => ToTerm (Expr Void a) where
TList [ TInt 15, TInteger (fromIntegral n) ]
encode (IntegerLit n) =
TList [ TInt 16, TInteger n ]
encode (DoubleLit n64)
-- cborg always encodes NaN as "7e00"
| isNaN n64 = THalf n32
| useHalf = THalf n32
| useFloat = TFloat n32
| otherwise = TDouble n64
where
n32 = double2Float n64
useFloat = n64 == float2Double n32
-- the other three cases for Half-floats are 0.0 and the infinities
useHalf = or $ fmap (n64 ==) [0.0, infinity, -infinity]
infinity = 1/0 :: Double
encode (DoubleLit d) =
encode d
encode (TextLit (Chunks xys₀ z₀)) =
TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ])
where
@ -472,6 +463,20 @@ instance ToTerm Import where
instance ToTerm Void where
encode = absurd
instance ToTerm DhallDouble where
encode (DhallDouble n64)
-- cborg always encodes NaN as "7e00"
| isNaN n64 = THalf n32
| useHalf = THalf n32
| useFloat = TFloat n32
| otherwise = TDouble n64
where
n32 = double2Float n64
useFloat = n64 == float2Double n32
-- the other three cases for Half-floats are 0.0 and the infinities
useHalf = or $ fmap (n64 ==) [0.0, infinity, -infinity]
infinity = 1/0 :: Double
-- | Types that can be decoded from a CBOR `Term`
class FromTerm a where
decode :: Term -> Maybe a
@ -693,11 +698,11 @@ instance FromTerm a => FromTerm (Expr s a) where
decode (TList [ TInt 16, TInteger n ]) = do
return (IntegerLit n)
decode (THalf n) = do
return (DoubleLit (float2Double n))
return (DoubleLit (DhallDouble (float2Double n)))
decode (TFloat n) = do
return (DoubleLit (float2Double n))
return (DoubleLit (DhallDouble (float2Double n)))
decode (TDouble n) = do
return (DoubleLit n)
return (DoubleLit (DhallDouble n))
decode (TList (TInt 18 : xs)) = do
let process (TString x : y₁ : zs) = do
y₀ <- decode y₁

10
dhall/src/Dhall/Binary.hs-boot
View File

@ -1,10 +0,0 @@
module Dhall.Binary where
import Codec.CBOR.Term (Term)
import {-# SOURCE #-} Dhall.Core
class ToTerm a where
encode :: a -> Term
instance ToTerm a => ToTerm (Expr s a)

72
dhall/src/Dhall/Core.hs
View File

@ -30,6 +30,7 @@ module Dhall.Core (
, ImportType(..)
, URL(..)
, Scheme(..)
, DhallDouble(..)
, Var(..)
, Chunks(..)
, Expr(..)
@ -83,6 +84,7 @@ import Control.DeepSeq (NFData)
import Control.Exception (Exception)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (Bifunctor(..))
import Data.Bits (xor)
import Data.Data (Data)
import Data.Foldable
import Data.Functor.Identity (Identity(..))
@ -110,17 +112,17 @@ import Unsafe.Coerce (unsafeCoerce)
import qualified Control.Exception
import qualified Control.Monad
import qualified Data.Char
import {-# SOURCE #-} qualified Dhall.Eval as Eval
import {-# SOURCE #-} qualified Dhall.Eval as Eval
import qualified Data.HashSet
import qualified Data.List.NonEmpty
import qualified Data.Sequence
import qualified Data.Set
import qualified Data.Text
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Dhall.Crypto
import qualified Dhall.Map
import qualified Dhall.Set
import qualified Network.URI as URI
import qualified Network.URI as URI
import qualified Text.Printf
@ -324,6 +326,38 @@ instance Pretty Import where
Location -> " as Location"
Code -> ""
-- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is
-- defined via the binary encoding of Dhall @Double@s.
newtype DhallDouble = DhallDouble { getDhallDouble :: Double }
deriving (Show, Data, NFData, Generic)
-- | This instance satisfies all the customary 'Eq' laws except substitutivity.
--
-- In particular:
--
-- >>> nan = DhallDouble (0/0)
-- >>> nan == nan
-- True
--
-- This instance is also consistent with with the binary encoding of Dhall @Double@s:
--
-- >>> toBytes n = Codec.Serialise.serialise (Dhall.Binary.encode (n :: DhallDouble))
--
-- prop> \a b -> (a == b) == (toBytes a == toBytes b)
instance Eq DhallDouble where
DhallDouble a == DhallDouble b
| isNaN a && isNaN b = True
| isNegativeZero a `xor` isNegativeZero b = False
| otherwise = a == b
-- | This instance relies on the 'Eq' instance for 'DhallDouble' but cannot
-- satisfy the customary 'Ord' laws when @NaN@ is involved.
instance Ord DhallDouble where
compare a@(DhallDouble a') b@(DhallDouble b') =
if a == b
then EQ
else compare a' b'
{-| Label for a bound variable
The `Text` field is the variable's name (i.e. \"@x@\").
@ -462,7 +496,7 @@ data Expr s a
-- | > Double ~ Double
| Double
-- | > DoubleLit n ~ n
| DoubleLit Double
| DoubleLit DhallDouble
-- | > DoubleShow ~ Double/show
| DoubleShow
-- | > Text ~ Text
@ -541,18 +575,17 @@ data Expr s a
-- NB: If you add a constructor to Expr, please also update the Arbitrary
-- instance in Dhall.Test.QuickCheck.
-- | Note that this 'Eq' instance inherits `Double`'s defects, e.g.
-- | This instance encodes what the Dhall standard calls an \"exact match\"
-- between two expressions.
--
-- >>> nan = 0/0
-- Note that
--
-- >>> nan = DhallDouble (0/0)
-- >>> DoubleLit nan == DoubleLit nan
-- False
-- True
deriving instance (Eq s, Eq a) => Eq (Expr s a)
-- | Note that this 'Eq' instance inherits `Double`'s defects, e.g.
--
-- >>> nan = 0/0
-- >>> DoubleLit nan <= DoubleLit nan
-- False
-- | Note that this 'Ord' instance inherits `DhallDouble`'s defects.
deriving instance (Ord s, Ord a) => Ord (Expr s a)
instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a)
@ -1445,8 +1478,8 @@ normalizeWithM ctx e0 = loop (denote e0)
-- `(read . show)` is used instead of `fromInteger` because `read` uses
-- the correct rounding rule.
-- See https://gitlab.haskell.org/ghc/ghc/issues/17231.
App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((read . show) n))
App DoubleShow (DoubleLit n) ->
App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n))
App DoubleShow (DoubleLit (DhallDouble n)) ->
pure (TextLit (Chunks [] (Data.Text.pack (show n))))
App (App OptionalBuild _A₀) g ->
loop (App (App (App g optional) just) nothing)
@ -2390,3 +2423,14 @@ bindingExprs f (Binding s0 n s1 t s2 v) =
-}
makeBinding :: Text -> Expr s a -> Binding s a
makeBinding name = Binding Nothing name Nothing Nothing Nothing
{- $setup
>>> import qualified Codec.Serialise
>>> import qualified Dhall.Binary
>>> import Data.SpecialValues
>>> import Test.QuickCheck (Arbitrary(..), oneof, elements)
>>> :{
instance Arbitrary DhallDouble where
arbitrary = fmap DhallDouble (oneof [ arbitrary, elements specialValues ])
:}
-}

2
dhall/src/Dhall/Core.hs-boot
View File

@ -8,4 +8,6 @@ data Expr s a
data Import
data DhallDouble
denote :: Expr s a -> Expr t a

6
dhall/src/Dhall/Diff.hs
View File

@ -25,7 +25,7 @@ import Data.String (IsString(..))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty)
import Data.Void (Void)
import Dhall.Core (Binding(..), Chunks (..), Const(..), Expr(..), Var(..))
import Dhall.Core (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..))
import Dhall.Binary (ToTerm)
import Dhall.Map (Map)
import Dhall.Set (Set)
@ -185,8 +185,8 @@ diffLabels ksL ksR =
diffNatural :: Natural -> Natural -> Diff
diffNatural = diffPrimitive (token . Internal.prettyNatural)
diffDouble :: Double -> Double -> Diff
diffDouble = diffPrimitive (token . Internal.prettyDouble)
diffDouble :: DhallDouble -> DhallDouble -> Diff
diffDouble = diffPrimitive (token . Internal.prettyDouble . getDhallDouble)
diffConst :: Const -> Const -> Diff
diffConst = diffPrimitive (token . Internal.prettyConst)

15
dhall/src/Dhall/Eval.hs
View File

@ -62,7 +62,7 @@ import Dhall.Core
, Expr(..)
, Chunks(..)
, Const(..)
, Import
, DhallDouble(..)
, Var(..)
)
@ -71,11 +71,9 @@ import Dhall.Set (Set)
import GHC.Natural (Natural)
import Prelude hiding (succ)
import qualified Codec.Serialise as Serialise
import qualified Data.Sequence as Sequence
import qualified Data.Set
import qualified Data.Text as Text
import qualified Dhall.Binary as Binary
import qualified Dhall.Core as Core
import qualified Dhall.Map as Map
import qualified Dhall.Set
@ -195,7 +193,7 @@ data Val a
| VIntegerToDouble !(Val a)
| VDouble
| VDoubleLit !Double
| VDoubleLit !DhallDouble
| VDoubleShow !(Val a)
| VText
@ -533,7 +531,7 @@ eval !env t0 =
n -> VIntegerShow n
IntegerToDouble ->
VPrim $ \case
VIntegerLit n -> VDoubleLit (read (show n))
VIntegerLit n -> VDoubleLit (DhallDouble (read (show n)))
-- `(read . show)` is used instead of `fromInteger`
-- because `read` uses the correct rounding rule.
-- See https://gitlab.haskell.org/ghc/ghc/issues/17231.
@ -544,8 +542,8 @@ eval !env t0 =
VDoubleLit n
DoubleShow ->
VPrim $ \case
VDoubleLit n -> VTextLit (VChunks [] (Text.pack (show n)))
n -> VDoubleShow n
VDoubleLit (DhallDouble n) -> VTextLit (VChunks [] (Text.pack (show n)))
n -> VDoubleShow n
Text ->
VText
TextLit cs ->
@ -853,8 +851,7 @@ conv !env t0 t0' =
(VDouble, VDouble) ->
True
(VDoubleLit n, VDoubleLit n') ->
Serialise.serialise (Binary.encode (DoubleLit n :: Expr Void Import))
== Serialise.serialise (Binary.encode (DoubleLit n' :: Expr Void Import))
n == n'
(VDoubleShow t, VDoubleShow t') ->
conv env t t'
(VText, VText) ->

6
dhall/src/Dhall/Parser/Expression.hs
View File

@ -338,7 +338,7 @@ parsers embedded = Parsers {..}
b <- if isInfinite a
then setOffset n *> fail "double out of bounds"
else return a
return (DoubleLit b)
return (DoubleLit (DhallDouble b))
alternative01 = do
a <- try naturalLiteral
@ -373,7 +373,7 @@ parsers embedded = Parsers {..}
alternative09 = do
a <- try doubleInfinity
return (DoubleLit a)
return (DoubleLit (DhallDouble a))
builtin = do
let predicate c =
@ -388,7 +388,7 @@ parsers embedded = Parsers {..}
|| c == 'F'
|| c == 'K'
let nan = (0.0/0.0)
let nan = DhallDouble (0.0/0.0)
c <- Text.Megaparsec.lookAhead (Text.Megaparsec.satisfy predicate)

2
dhall/src/Dhall/Pretty/Internal.hs
View File

@ -963,7 +963,7 @@ prettyCharacterSet characterSet expression =
| otherwise = prettyNumber a
prettyPrimitiveExpression (NaturalLit a) =
prettyNatural a
prettyPrimitiveExpression (DoubleLit a) =
prettyPrimitiveExpression (DoubleLit (DhallDouble a)) =
prettyDouble a
prettyPrimitiveExpression (TextLit a) =
prettyChunks a

9
dhall/tests/Dhall/Test/QuickCheck.hs
View File

@ -16,6 +16,7 @@ import Dhall.Core
, Chunks(..)
, Const(..)
, Directory(..)
, DhallDouble(..)
, Expr(..)
, File(..)
, FilePrefix(..)
@ -45,6 +46,7 @@ import qualified Codec.Serialise
import qualified Data.Coerce
import qualified Data.List
import qualified Data.Sequence
import qualified Data.SpecialValues
import qualified Data.Text as Text
import qualified Dhall.Binary
import qualified Dhall.Context
@ -161,6 +163,13 @@ instance Arbitrary Const where
shrink = genericShrink
instance Arbitrary DhallDouble where
arbitrary = fmap DhallDouble (Test.QuickCheck.oneof [ arbitrary, special ])
where
special = Test.QuickCheck.elements Data.SpecialValues.specialValues
shrink = genericShrink
instance Arbitrary Directory where
arbitrary = lift1 Directory

8
dhall/tests/Dhall/Test/Regression.hs
View File

@ -40,6 +40,7 @@ tests =
, issue253
, issue1131a
, issue1131b
, issue1341
, parsing0
, typeChecking0
, typeChecking1
@ -171,6 +172,13 @@ issue1131b :: TestTree
issue1131b = Test.Tasty.HUnit.testCase "Issue #1131 b"
(Util.assertDoesntTypeCheck "toMap {=} : List {mapKey : Text, mapValue : 0}")
issue1341 :: TestTree
issue1341 = Test.Tasty.HUnit.testCase "Issue #1341" (do
let nan = Dhall.Core.DoubleLit (Dhall.Core.DhallDouble (0/0)) :: Dhall.Core.Expr () ()
let actual = Dhall.Core.V "x" 0 `Dhall.Core.freeIn` nan
let msg = "NaN shouldn't contain any free variables"
Test.Tasty.HUnit.assertEqual msg False actual)
parsing0 :: TestTree
parsing0 = Test.Tasty.HUnit.testCase "Parsing regression #0" (do
-- Verify that parsing should not fail

7
dhall/tests/Dhall/Test/TypeInference.hs
View File

@ -44,12 +44,7 @@ getTests = do
successTest :: Text -> TestTree
successTest prefix = do
let skip = [ -- We correctly infer the expected type @NaN ≡ NaN@ here,
-- but the comparison between the inferred and the expected type
-- fails due to `Expr`'s 'Eq' instance, which inherits the
-- @NaN /= NaN@ inequality from 'Double'.
typeInferenceDirectory </> "success/unit/AssertNaN"
]
let skip = []
Test.Util.testCase prefix skip $ do
let prefixFP = Text.unpack prefix

2
stack-lts-6.yaml
View File

@ -34,6 +34,7 @@ extra-deps:
- generic-random-1.3.0.0
- hashable-1.2.7.0
- haskeline-0.7.4.2
- ieee754-0.8.0@sha256:ecabc40b844b76e95ca844cba42a9c335516b82971047e90f0e8cf95763d436a,1103
- integer-logarithms-1.0.3
- megaparsec-7.0.3
- memory-0.14.14
@ -58,6 +59,7 @@ extra-deps:
- semigroups-0.18.5
- serialise-0.2.1.0
- shell-escape-0.2.0
- special-values-0.1.0.0@sha256:c3cf13fdaa32105416f2f145f334cdb1995d789695c231f37682d9a20a754134,1344
- splitmix-0.0.2
- system-fileio-0.3.16.4
- tagged-0.8.6