Add support for Scientific (#256)

Fixes https://github.com/dhall-lang/dhall-lang/issues/86

This change has two benefits:

* Users of the Haskell API can now marshal Dhall values of type `Double` into
  Haskell values of type `Scientific`
* The `dhall` executable no longer loses precision when dealing with
  values that have a large exponent (see the newly added test)

default.nix

@@ -1,10 +1,10 @@
 { mkDerivation, ansi-wl-pprint, base, base16-bytestring, bytestring
 , case-insensitive, charset, containers, contravariant, cryptohash
-, deepseq, exceptions, http-client, http-client-tls
-, insert-ordered-containers, lens-family-core, optparse-generic
-, parsers, prettyprinter, stdenv, system-fileio, system-filepath
-, tasty, tasty-hunit, text, text-format, transformers, trifecta
-, unordered-containers, vector
+, deepseq, directory, exceptions, filepath, http-client
+, http-client-tls, insert-ordered-containers, lens-family-core
+, optparse-generic, parsers, prettyprinter, scientific, stdenv
+, system-filepath, tasty, tasty-hunit, text, text-format
+, transformers, trifecta, unordered-containers, vector
 }:
 mkDerivation {
   pname = "dhall";
@@ -14,16 +14,17 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     ansi-wl-pprint base base16-bytestring bytestring case-insensitive
-    charset containers contravariant cryptohash exceptions http-client
-    http-client-tls insert-ordered-containers lens-family-core parsers
-    prettyprinter system-fileio system-filepath text text-format
+    charset containers contravariant cryptohash directory exceptions
+    filepath http-client http-client-tls insert-ordered-containers
+    lens-family-core parsers prettyprinter scientific text text-format
     transformers trifecta unordered-containers vector
   ];
   executableHaskellDepends = [
     base optparse-generic prettyprinter system-filepath text trifecta
   ];
   testHaskellDepends = [
-    base containers deepseq prettyprinter tasty tasty-hunit text vector
+    base containers deepseq insert-ordered-containers prettyprinter
+    tasty tasty-hunit text vector
   ];
   description = "A configuration language guaranteed to terminate";
   license = stdenv.lib.licenses.bsd3;

dhall.cabal

@@ -111,6 +111,7 @@ Library
         lens-family-core          >= 1.0.0    && < 1.3 ,
         parsers                   >= 0.12.4   && < 0.13,
         prettyprinter             >= 1.1.1    && < 1.2 ,
+        scientific                >= 0.3.0.0  && < 0.4 ,
         text                      >= 0.11.1.0 && < 1.3 ,
         text-format                              < 0.4 ,
         transformers              >= 0.2.0.0  && < 0.6 ,

src/Dhall.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 
 {-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
@@ -34,6 +35,7 @@ module Dhall
     , bool
     , natural
     , integer
+    , scientific
     , double
     , lazyText
     , strictText
@@ -63,6 +65,7 @@ import Control.Exception (Exception)
 import Control.Monad.Trans.State.Strict
 import Data.Functor.Contravariant (Contravariant(..))
 import Data.Monoid ((<>))
+import Data.Scientific (Scientific)
 import Data.Text.Buildable (Buildable(..))
 import Data.Text.Lazy (Text)
 import Data.Typeable (Typeable)
@@ -81,6 +84,7 @@ import qualified Control.Exception
 import qualified Data.ByteString.Lazy
 import qualified Data.Foldable
 import qualified Data.HashMap.Strict.InsOrd
+import qualified Data.Scientific
 import qualified Data.Sequence
 import qualified Data.Set
 import qualified Data.Text
@@ -379,18 +383,26 @@ integer = Type {..}
 
     expected = Integer
 
+{-| Decode a `Scientific`
+
+>>> input scientific "1e1000000000"
+1.0e1000000000
+-}
+scientific :: Type Scientific
+scientific = Type {..}
+  where
+    extract (DoubleLit n) = pure n
+    extract  _            = empty
+
+    expected = Double
+
 {-| Decode a `Double`
 
 >>> input double "42.0"
 42.0
 -}
 double :: Type Double
-double = Type {..}
-  where
-    extract (DoubleLit n) = pure n
-    extract  _            = empty
-
-    expected = Double
+double = fmap Data.Scientific.toRealFloat scientific
 
 {-| Decode lazy `Text`
 
@@ -518,6 +530,9 @@ instance Interpret Natural where
 instance Interpret Integer where
     autoWith _ = integer
 
+instance Interpret Scientific where
+    autoWith _ = scientific
+
 instance Interpret Double where
     autoWith _ = double
 
@@ -847,14 +862,17 @@ instance Inject Word64 where
 
         declared = Integer
 
-
-instance Inject Double where
+instance Inject Scientific where
     injectWith _ = InputType {..}
       where
         embed = DoubleLit
 
         declared = Double
 
+instance Inject Double where
+    injectWith =
+        fmap (contramap (Data.Scientific.fromFloatDigits @Double)) injectWith
+
 instance Inject () where
     injectWith _ = InputType {..}
       where

src/Dhall/Core.hs

@@ -56,6 +56,7 @@ import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import Data.HashSet (HashSet)
 import Data.Monoid ((<>))
 import Data.String (IsString(..))
+import Data.Scientific (Scientific)
 import Data.Text.Buildable (Buildable(..))
 import Data.Text.Lazy (Text)
 import Data.Text.Lazy.Builder (Builder)
@@ -75,8 +76,8 @@ import qualified Data.HashSet
 import qualified Data.List
 import qualified Data.Maybe
 import qualified Data.Text
-import qualified Data.Text.Lazy            as Text
-import qualified Data.Text.Lazy.Builder    as Builder
+import qualified Data.Text.Lazy                        as Text
+import qualified Data.Text.Lazy.Builder                as Builder
 import qualified Data.Text.Prettyprint.Doc             as Pretty
 import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
 import qualified Data.Vector
@@ -270,7 +271,7 @@ data Expr s a
     -- | > Double                                   ~  Double
     | Double
     -- | > DoubleLit n                              ~  n
-    | DoubleLit Double
+    | DoubleLit Scientific
     -- | > DoubleShow                               ~  Double/show
     | DoubleShow
     -- | > Text                                     ~  Text
@@ -613,8 +614,8 @@ prettyNumber = Pretty.pretty
 prettyNatural :: Natural -> Doc ann
 prettyNatural = Pretty.pretty
 
-prettyDouble :: Double -> Doc ann
-prettyDouble = Pretty.pretty
+prettyScientific :: Scientific -> Doc ann
+prettyScientific = Pretty.pretty . show
 
 prettyChunks :: Pretty a => Chunks s a -> Doc ann
 prettyChunks (Chunks a b) =
@@ -1038,7 +1039,7 @@ prettyExprF (IntegerLit a) =
 prettyExprF (NaturalLit a) =
     "+" <> prettyNatural a
 prettyExprF (DoubleLit a) =
-    prettyDouble a
+    prettyScientific a
 prettyExprF (TextLit a) =
     prettyChunks a
 prettyExprF (Record a) =
@@ -1121,8 +1122,8 @@ buildNatural :: Natural -> Builder
 buildNatural a = build (show a)
 
 -- | Builder corresponding to the @double@ token in "Dhall.Parser"
-buildDouble :: Double -> Builder
-buildDouble a = build (show a)
+buildScientific :: Scientific -> Builder
+buildScientific = build . show
 
 -- | Builder corresponding to the @text@ token in "Dhall.Parser"
 buildChunks :: Buildable a => Chunks s a -> Builder
@@ -1389,7 +1390,7 @@ buildExprF (IntegerLit a) =
 buildExprF (NaturalLit a) =
     "+" <> buildNatural a
 buildExprF (DoubleLit a) =
-    buildDouble a
+    buildScientific a
 buildExprF (TextLit a) =
     buildChunks a
 buildExprF (Record a) =
@@ -2044,7 +2045,7 @@ normalizeWith ctx e0 = loop (denote e0)
             App IntegerShow (IntegerLit n) ->
                 TextLit (Chunks [] (buildNumber n))
             App DoubleShow (DoubleLit n) ->
-                TextLit (Chunks [] (buildDouble n))
+                TextLit (Chunks [] (buildScientific n))
             App (App OptionalBuild t) k
                 | check     -> OptionalLit t k'
                 | otherwise -> App f' a'

src/Dhall/Parser.hs

@@ -27,6 +27,7 @@ import Data.Functor (void)
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import Data.Monoid ((<>))
 import Data.Sequence (ViewL(..))
+import Data.Scientific (Scientific)
 import Data.String (IsString(..))
 import Data.Text.Buildable (Buildable(..))
 import Data.Text.Lazy (Text)
@@ -687,11 +688,11 @@ _arrow = do
     void (Text.Parser.Char.char '→' <?> "\"→\"") <|> void (Text.Parser.Char.text "->")
     whitespace
 
-doubleLiteral :: Parser Double
+doubleLiteral :: Parser Scientific
 doubleLiteral = (do
     sign <-  fmap (\_ -> negate) (Text.Parser.Char.char '-')
          <|> pure id
-    a    <-  Text.Parser.Token.double
+    a    <-  Text.Parser.Token.scientific
     return (sign a) ) <?> "double literal"
 
 integerLiteral :: Parser Integer

tests/Format.hs

@@ -30,6 +30,9 @@ formatTests =
         , should
             "escape numeric labels correctly"
             "escapeNumericLabel"
+        , should
+            "correctly handle scientific notation with a large exponent"
+            "largeExponent"
         ]
 
 opts :: Data.Text.Prettyprint.Doc.LayoutOptions

tests/format/largeExponentA.dhall

@@ -0,0 +1 @@
+[ 1.0, 1e1000000000, 1e-1000000000 ]

tests/format/largeExponentB.dhall

@@ -0,0 +1 @@
+[ 1.0, 1.0e1000000000, 1.0e-1000000000 ]