Implement language support for Bytes (dhall-lang#2499)

… as standardized in dhall-lang/dhall-lang#1323

dhall-bash/src/Dhall/Bash.hs

@@ -292,6 +292,8 @@ dhallToStatement expr0 var0 = go (Dhall.Core.normalize expr0)
     go e@(BoolEQ           {}) = Left (UnsupportedStatement e)
     go e@(BoolNE           {}) = Left (UnsupportedStatement e)
     go e@(BoolIf           {}) = Left (UnsupportedStatement e)
+    go e@(Bytes              ) = Left (UnsupportedStatement e)
+    go e@(BytesLit         {}) = Left (UnsupportedStatement e)
     go e@(Natural            ) = Left (UnsupportedStatement e)
     go e@(NaturalFold        ) = Left (UnsupportedStatement e)
     go e@(NaturalBuild       ) = Left (UnsupportedStatement e)

dhall-json/src/Dhall/JSON.hs

@@ -797,6 +797,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
             b' = loop b
             c' = loop c
 
+        Core.Bytes ->
+            Core.Bytes
+
+        Core.BytesLit a ->
+            Core.BytesLit a
+
         Core.Natural ->
             Core.Natural
 

dhall-nix/src/Dhall/Nix.hs

@@ -163,6 +163,9 @@ data CompileError
     -- ^ We currently do not support threading around type information
     | CannotShowConstructor
     -- ^ We currently do not support the `showConstructor` keyword
+    | BytesUnsupported
+    -- ^ The Nix language does not support arbitrary bytes (most notably: null
+    --   bytes)
     deriving (Typeable)
 
 instance Show CompileError where
@@ -237,6 +240,13 @@ doesn't survive β-normalization, so if you see this error message there might b
 an internal error in ❰dhall-to-nix❱ that you should report.
     |]
 
+    show BytesUnsupported =
+        Data.Text.unpack [NeatInterpolation.text|
+$_ERROR: Cannot translate ❰Bytes❱ to Nix
+
+Explanation: The Nix language does not support bytes literals
+    |]
+
 _ERROR :: Data.Text.Text
 _ERROR = "\ESC[1;31mError\ESC[0m"
 
@@ -376,6 +386,9 @@ dhallToNix e =
         b' <- loop b
         c' <- loop c
         return (Nix.mkIf a' b' c')
+    loop Bytes = return untranslatable
+    loop (BytesLit _) = do
+        Left BytesUnsupported
     loop Natural = return untranslatable
     loop (NaturalLit n) = return (Nix.mkInt (fromIntegral n))
     loop NaturalFold = do

dhall-nixpkgs/Main.hs

@@ -356,6 +356,7 @@ findExternalDependencies expression = do
     case importMode of
         Code     -> return ()
         RawText  -> return ()
+        RawBytes -> return ()
         Location -> empty  -- "as Location" imports aren't real dependencies
 
     case importType of

dhall/dhall.cabal

@@ -170,6 +170,7 @@ Extra-Source-Files:
     dhall-lang/tests/**/*.dhallb
     dhall-lang/tests/**/*.hash
     dhall-lang/tests/**/*.txt
+    dhall-lang/tests/**/*.bin
     dhall-lang/tests/import/cache/dhall/12203871180b87ecaba8b53fffb2a8b52d3fce98098fab09a6f759358b9e8042eedc
     dhall-lang/tests/import/cache/dhall/1220618f785ce8f3930a9144398f576f0a992544b51212bc9108c31b4e670dc6ed21
     tests/**/*.dhall

dhall/ghc-src/Dhall/Import/HTTP.hs

@@ -4,6 +4,7 @@
 
 module Dhall.Import.HTTP
     ( fetchFromHttpUrl
+    , fetchFromHttpUrlBytes
     , originHeadersFileExpr
     ) where
 
@@ -38,11 +39,10 @@ import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..))
 
 import qualified Control.Exception
 import qualified Control.Monad.Trans.State.Strict as State
+import qualified Data.ByteString.Lazy             as ByteString.Lazy
 import qualified Data.HashMap.Strict              as HashMap
 import qualified Data.Text                        as Text
 import qualified Data.Text.Encoding
-import qualified Data.Text.Lazy
-import qualified Data.Text.Lazy.Encoding
 import qualified Dhall.Util
 import qualified Network.HTTP.Client              as HTTP
 import qualified Network.HTTP.Types
@@ -266,8 +266,9 @@ addHeaders originHeaders urlHeaders request =
         matchesKey :: CI ByteString -> HTTPHeader -> Bool
         matchesKey key (candidate, _value) = key == candidate
 
-fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text
-fetchFromHttpUrl childURL mheaders = do
+fetchFromHttpUrlBytes
+    :: URL -> Maybe [HTTPHeader] -> StateT Status IO ByteString
+fetchFromHttpUrlBytes childURL mheaders = do
     Status { _loadOriginHeaders } <- State.get
 
     originHeaders <- _loadOriginHeaders
@@ -300,16 +301,20 @@ fetchFromHttpUrl childURL mheaders = do
         _ -> do
             return ()
 
-    let bytes = HTTP.responseBody response
+    return (ByteString.Lazy.toStrict (HTTP.responseBody response))
+
+fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text
+fetchFromHttpUrl childURL mheaders = do
+    bytes <- fetchFromHttpUrlBytes childURL mheaders
 
-    case Data.Text.Lazy.Encoding.decodeUtf8' bytes of
+    case Data.Text.Encoding.decodeUtf8' bytes of
         Left  err  -> liftIO (Control.Exception.throwIO err)
-        Right text -> return (Data.Text.Lazy.toStrict text)
+        Right text -> return text
 
 originHeadersFileExpr :: IO (Expr Src Import)
 originHeadersFileExpr = do
     directoryStr <- getXdgDirectory XdgConfig "dhall"
     let components = map Text.pack (splitDirectories directoryStr)
     let directory = Directory (reverse components)
     let file = (File directory "headers.dhall")
-    return (Embed (Import (ImportHashed Nothing (Local Absolute file)) Code))
+    return (Embed (Import (ImportHashed Nothing (Local Absolute file)) Code))

dhall/ghcjs-src/Dhall/Import/HTTP.hs

@@ -2,6 +2,7 @@
 
 module Dhall.Import.HTTP
     ( fetchFromHttpUrl
+    , fetchFromHttpUrlBytes
     , originHeadersFileExpr
     ) where
 
@@ -14,7 +15,8 @@ import Dhall.Import.Types               (Import, Status)
 import Dhall.Parser                     (Src)
 import Dhall.URL                        (renderURL)
 
-import qualified Data.Text      as Text
+import qualified Data.Text          as Text
+import qualified Data.Text.Encoding as Text.Encoding
 import qualified JavaScript.XHR
 
 fetchFromHttpUrl
@@ -38,5 +40,13 @@ fetchFromHttpUrl childURL Nothing = do
 fetchFromHttpUrl _ _ =
     fail "Dhall does not yet support custom headers when built using GHCJS"
 
+fetchFromHTTPUrlBytes
+    :: URL
+    -> Maybe [(CI ByteString, ByteString)]
+    -> StateT Status IO ByteString
+fetchFromHTTPUrlBytes childUrl mheader = do
+    text <- fetchFromHTTPUrl childUrl mheader
+    return (Text.Encoding.encodeUtf8 text)
+
 originHeadersFileExpr :: IO (Expr Src Import)
 originHeadersFileExpr = return Missing

dhall/src/Dhall/Binary.hs

@@ -144,6 +144,7 @@ decodeExpressionInternal decodeEmbed = go
                        | sb == "Type"              -> return (Const Type)
                        | sb == "Kind"              -> return (Const Kind)
                        | sb == "Sort"              -> return (Const Sort)
+                    5  | sb == "Bytes"             -> return Bytes
                     6  | sb == "Double"            -> return Double
                     7  | sb == "Integer"           -> return Integer
                        | sb == "Natural"           -> return Natural
@@ -650,6 +651,12 @@ decodeExpressionInternal decodeEmbed = go
                                 let minutes = sign (_HH * 60 + _MM)
 
                                 return (TimeZoneLiteral (Time.TimeZone minutes False ""))
+
+                            33 -> do
+                                b <- Decoding.decodeBytes
+
+                                return (BytesLit b)
+
                             34 -> do
                                 t <- go
                                 return (ShowConstructor t)
@@ -737,6 +744,9 @@ encodeExpressionInternal encodeEmbed = go
         Bool ->
             Encoding.encodeUtf8ByteArray "Bool"
 
+        Bytes ->
+            Encoding.encodeUtf8ByteArray "Bytes"
+
         Optional ->
             Encoding.encodeUtf8ByteArray "Optional"
 
@@ -830,6 +840,11 @@ encodeExpressionInternal encodeEmbed = go
         BoolNE l r ->
             encodeOperator 3 l r
 
+        BytesLit b ->
+            encodeList2
+                (Encoding.encodeInt 33)
+                (Encoding.encodeBytes b)
+
         NaturalPlus l r ->
             encodeOperator 4 l r
 
@@ -1157,6 +1172,7 @@ decodeImport len = do
         0 -> return Code
         1 -> return RawText
         2 -> return Location
+        3 -> return RawBytes
         _ -> die ("Unexpected code for import mode: " <> show m)
 
     let remote scheme = do
@@ -1295,7 +1311,11 @@ encodeImport import_ =
             Just digest ->
                 Encoding.encodeBytes ("\x12\x20" <> Dhall.Crypto.unSHA256Digest digest)
 
-        m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;)
+        m = Encoding.encodeInt (case importMode of
+            Code -> 0
+            RawText -> 1
+            Location -> 2
+            RawBytes -> 3 )
 
     Import{..} = import_
 

dhall/src/Dhall/Diff.hs

@@ -17,6 +17,7 @@ module Dhall.Diff (
     , diff
     ) where
 
+import Data.ByteString       (ByteString)
 import Data.Foldable         (fold, toList)
 import Data.List.NonEmpty    (NonEmpty (..))
 import Data.Monoid           (Any (..))
@@ -40,16 +41,16 @@ import Dhall.Syntax
 import Numeric.Natural       (Natural)
 import Prettyprinter         (Doc, Pretty)
 
-import qualified Data.Algorithm.Diff   as Algo.Diff
+import qualified Data.Algorithm.Diff    as Algo.Diff
 import qualified Data.List.NonEmpty
 import qualified Data.Set
 import qualified Data.Text
-import qualified Data.Time             as Time
+import qualified Data.Time              as Time
 import qualified Dhall.Map
-import qualified Dhall.Normalize       as Normalize
-import qualified Dhall.Pretty.Internal as Internal
-import qualified Dhall.Syntax          as Syntax
-import qualified Prettyprinter         as Pretty
+import qualified Dhall.Normalize        as Normalize
+import qualified Dhall.Pretty.Internal  as Internal
+import qualified Dhall.Syntax           as Syntax
+import qualified Prettyprinter          as Pretty
 
 {-| This type is a `Doc` enriched with a `same` flag to efficiently track if
     any difference was detected
@@ -383,6 +384,10 @@ diffChunks cL cR
         (Right x, Right y) -> diff x y
         _                  -> diffTextSkeleton
 
+diffBytes :: ByteString -> ByteString -> Diff
+diffBytes l r =
+    "0x" <> diffText (Internal.prettyBase16 l) (Internal.prettyBase16 r)
+
 diffList
     :: (Eq a, Pretty a)
     => Seq (Expr Void a) -> Seq (Expr Void a) -> Diff
@@ -532,6 +537,10 @@ skeleton (BoolIf {}) =
     <>  keyword "else"
     <>  " "
     <>  ignore
+skeleton (BytesLit {}) =
+        "0x\""
+    <>  ignore
+    <>  "\""
 skeleton (NaturalPlus {}) =
         ignore
     <>  " "
@@ -1169,6 +1178,18 @@ diffPrimitiveExpression l@Bool r =
     mismatch l r
 diffPrimitiveExpression l r@Bool =
     mismatch l r
+diffPrimitiveExpression Bytes Bytes =
+    "…"
+diffPrimitiveExpression l@Bytes r =
+    mismatch l r
+diffPrimitiveExpression l r@Bytes =
+    mismatch l r
+diffPrimitiveExpression (BytesLit l) (BytesLit r) =
+    diffBytes l r
+diffPrimitiveExpression l@(BytesLit {}) r =
+    mismatch l r
+diffPrimitiveExpression l r@(BytesLit {}) =
+    mismatch l r
 diffPrimitiveExpression Natural Natural =
     "…"
 diffPrimitiveExpression l@Natural r =

dhall/src/Dhall/Eval.hs

@@ -49,6 +49,7 @@ module Dhall.Eval (
   ) where
 
 import Data.Bifunctor     (first)
+import Data.ByteString    (ByteString)
 import Data.Foldable      (foldr', toList)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Sequence      (Seq, ViewL (..), ViewR (..))
@@ -170,6 +171,9 @@ data Val a
     | VBoolNE !(Val a) !(Val a)
     | VBoolIf !(Val a) !(Val a) !(Val a)
 
+    | VBytes
+    | VBytesLit ByteString
+
     | VNatural
     | VNaturalLit !Natural
     | VNaturalFold !(Val a) !(Val a) !(Val a) !(Val a)
@@ -490,6 +494,10 @@ eval !env t0 =
                 (b', VBoolLit True, VBoolLit False) -> b'
                 (_, t', f') | conv env t' f'        -> t'
                 (b', t', f')                        -> VBoolIf b' t' f'
+        Bytes ->
+            VBytes
+        BytesLit b ->
+            VBytesLit b
         Natural ->
             VNatural
         NaturalLit n ->
@@ -940,6 +948,10 @@ conv !env t0 t0' =
             conv env t t' && conv env u u'
         (VBoolIf t u v, VBoolIf t' u' v') ->
             conv env t t' && conv env u u' && conv env v v'
+        (VBytes, VBytes) ->
+            True
+        (VBytesLit l, VBytesLit r) ->
+            l == r
         (VNatural, VNatural) ->
             True
         (VNaturalLit n, VNaturalLit n') ->
@@ -1152,6 +1164,10 @@ quote !env !t0 =
             BoolNE (quote env t) (quote env u)
         VBoolIf t u v ->
             BoolIf (quote env t) (quote env u) (quote env v)
+        VBytes ->
+            Bytes
+        VBytesLit b ->
+            BytesLit b
         VNatural ->
             Natural
         VNaturalLit n ->
@@ -1351,6 +1367,10 @@ alphaNormalize = goEnv EmptyNames
                 BoolNE  (go t) (go u)
             BoolIf b t f ->
                 BoolIf  (go b) (go t) (go f)
+            Bytes ->
+                Bytes
+            BytesLit b ->
+                BytesLit b
             Natural ->
                 Natural
             NaturalLit n ->