Add with support for Optional values (#2386)

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

Co-authored-by: David Richey <[email protected]>

Author: Gabriella439

dhall-nix/src/Dhall/Nix.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE QuasiQuotes        #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE ViewPatterns       #-}
 
@@ -93,24 +94,30 @@ module Dhall.Nix (
     ) where
 
 import Control.Exception (Exception)
-import Data.Fix          (Fix (..))
-import Data.Foldable     (toList)
-import Data.Text         (Text)
-import Data.Traversable  (for)
-import Data.Typeable     (Typeable)
-import Data.Void         (Void, absurd)
+import Data.Fix (Fix (..))
+import Data.Foldable (toList)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import Data.Traversable (for)
+import Data.Typeable (Typeable)
+import Data.Void (Void, absurd)
+import Lens.Family (toListOf)
+import Nix.Atoms (NAtom (..))
+import Nix (($//), ($==))
+
 import Dhall.Core
     ( Binding (..)
     , Chunks (..)
     , DhallDouble (..)
     , Expr (..)
+    , FieldSelection (..)
     , FunctionBinding (..)
     , MultiLet (..)
     , PreferAnnotation (..)
     , Var (..)
+    , WithComponent (..)
     )
-import Lens.Family       (toListOf)
-import Nix.Atoms         (NAtom (..))
+
 import Nix.Expr
     ( Antiquoted (..)
     , Binding (..)
@@ -670,8 +677,24 @@ dhallToNix e =
         return untranslatable
     loop (Equivalent _ _ _) =
         return untranslatable
-    loop a@With{} =
-        loop (Dhall.Core.desugarWith a)
+    loop (With a (WithLabel k :| []) b) = do
+        a' <- loop a
+        b' <- loop b
+
+        return (a' $// Nix.attrsE [(k, b')])
+    loop (With a (WithLabel k :| k' : ks) b) = do
+        a' <- loop a
+        b' <- loop (With (Field "_" (FieldSelection Nothing k Nothing)) (k' :| ks) (Dhall.Core.shift 1 "_" b))
+
+        return (Nix.letE "_" a' ("_" $// Nix.attrsE [(k, b')]))
+    loop (With a (WithQuestion :| []) b) = do
+        a' <- loop a
+        b' <- loop b
+        return (Nix.mkIf (a' $== Nix.mkNull) Nix.mkNull b')
+    loop (With a (WithQuestion :| k : ks) b) = do
+        a' <- loop a
+        b' <- loop (With "_" (k :| ks) (Dhall.Core.shift 1 "_" b))
+        return (Nix.letE "_" a' (Nix.mkIf (a' $== Nix.mkNull) Nix.mkNull b'))
     loop (ImportAlt a _) = loop a
     loop (Note _ b) = loop b
     loop (Embed x) = absurd x

dhall/src/Dhall/Binary.hs

@@ -47,6 +47,7 @@ import Dhall.Syntax
     , Scheme (..)
     , URL (..)
     , Var (..)
+    , WithComponent (..)
     )
 
 import Data.Foldable (toList)
@@ -559,7 +560,18 @@ decodeExpressionInternal decodeEmbed = go
 
                                 n <- Decoding.decodeListLen
 
-                                ks₀ <- replicateDecoder n Decoding.decodeString
+                                let decodeWithComponent = do
+                                        tokenType₂ <- Decoding.peekTokenType
+                                        case tokenType₂ of
+                                            TypeString -> do
+                                                fmap WithLabel Decoding.decodeString
+                                            _ -> do
+                                                m <- Decoding.decodeInt
+
+                                                case m of
+                                                    0 -> return WithQuestion
+                                                    _ -> die ("Unexpected integer encoding a with expression: " <> show n)
+                                ks₀ <- replicateDecoder n decodeWithComponent
 
                                 ks₁ <- case NonEmpty.nonEmpty ks₀ of
                                     Nothing ->
@@ -1017,8 +1029,11 @@ encodeExpressionInternal encodeEmbed = go
             encodeList4
                 (Encoding.encodeInt 29)
                 (go l)
-                (encodeList (fmap Encoding.encodeString ks))
+                (encodeList (fmap encodeWithComponent ks))
                 (go r)
+          where
+            encodeWithComponent  WithQuestion  = Encoding.encodeInt 0
+            encodeWithComponent (WithLabel k ) = Encoding.encodeString k
 
         DateLiteral day ->
             encodeList4

dhall/src/Dhall/Core.hs

@@ -31,6 +31,7 @@ module Dhall.Core (
     , makeFunctionBinding
     , FieldSelection (..)
     , makeFieldSelection
+    , WithComponent (..)
     , Expr(..)
 
     -- * Normalization
@@ -76,7 +77,6 @@ module Dhall.Core (
     , Eval.textShow
     , censorExpression
     , censorText
-    , Syntax.desugarWith
     ) where
 
 import Control.Exception      (Exception)
@@ -92,8 +92,7 @@ import Prettyprinter          (Pretty)
 
 import qualified Control.Exception
 import qualified Data.Text
-import qualified Dhall.Eval        as Eval
-import qualified Dhall.Syntax      as Syntax
+import qualified Dhall.Eval         as Eval
 
 -- | Pretty-print a value
 pretty :: Pretty a => a -> Text

dhall/src/Dhall/Diff.hs

@@ -35,6 +35,7 @@ import Dhall.Syntax
     , FunctionBinding (..)
     , RecordField (..)
     , Var (..)
+    , WithComponent (..)
     )
 import Numeric.Natural       (Natural)
 import Prettyprinter         (Doc, Pretty)
@@ -1067,12 +1068,15 @@ diffWithExpression (With eL ksL vL) (With eR ksR vR) =
         (   format " " (diffImportExpression eL eR)
         <>  "with "
         <>  align
-            (   format " " (diffPath ksL ksR)
+            (   format " " (diffPath (fmap toText ksL) (fmap toText ksR))
             <>  "= "
             <>  diffOperatorExpression vL vR
             )
         )
   where
+    toText  WithQuestion  = "?"
+    toText (WithLabel k ) = k
+
     diffPath (kL :| []) (kR :| []) =
         diffLabel kL kR
     diffPath (kL₀ :| kL₁ : ksL') (kR₀ :| kR₁ : ksR') =

dhall/src/Dhall/Eval.hs

@@ -69,6 +69,7 @@ import Dhall.Syntax
     , PreferAnnotation (..)
     , RecordField (..)
     , Var (..)
+    , WithComponent (..)
     )
 
 import qualified Data.Char
@@ -234,7 +235,7 @@ data Val a
     | VProject !(Val a) !(Either (Set Text) (Val a))
     | VAssert !(Val a)
     | VEquivalent !(Val a) !(Val a)
-    | VWith !(Val a) (NonEmpty Text) !(Val a)
+    | VWith !(Val a) (NonEmpty WithComponent) !(Val a)
     | VEmbed a
 
 -- | For use with "Text.Show.Functions".
@@ -417,16 +418,19 @@ vProjectByFields env t ks =
             t' ->
                 VProject t' (Left ks)
 
-vWith :: Val a -> NonEmpty Text -> Val a -> Val a
-vWith (VRecordLit kvs) (k  :| []     ) v = VRecordLit (Map.insert k  v  kvs)
-vWith (VRecordLit kvs) (k₀ :| k₁ : ks) v = VRecordLit (Map.insert k₀ e₂ kvs)
+vWith :: Val a -> NonEmpty WithComponent -> Val a -> Val a
+vWith (VRecordLit kvs) (WithLabel k  :| []     ) v = VRecordLit (Map.insert k  v  kvs)
+vWith (VRecordLit kvs) (WithLabel k₀ :| k₁ : ks) v = VRecordLit (Map.insert k₀ e₂ kvs)
   where
     e₁ =
         case Map.lookup k₀ kvs of
             Nothing  -> VRecordLit mempty
             Just e₁' -> e₁'
 
     e₂ = vWith e₁ (k₁ :| ks) v
+vWith (VNone _T) (WithQuestion :| _      ) _ = VNone _T
+vWith (VSome  _) (WithQuestion :| []     ) v = VSome v
+vWith (VSome  t) (WithQuestion :| k₁ : ks) v = VSome (vWith t (k₁ :| ks) v)
 vWith e₀ ks v₀ = VWith e₀ ks v₀
 
 eval :: forall a. Eq a => Environment a -> Expr Void a -> Val a

dhall/src/Dhall/Normalize.hs

@@ -38,6 +38,7 @@ import Dhall.Syntax
     , FunctionBinding (..)
     , PreferAnnotation (..)
     , RecordField (..)
+    , WithComponent (..)
     , Var (..)
     )
 
@@ -698,9 +699,9 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
         case e' of
             RecordLit kvs ->
                 case ks of
-                    k :| [] ->
+                    WithLabel k :| [] ->
                         return (RecordLit (Dhall.Map.insert k (Syntax.makeRecordField v') kvs))
-                    k₀ :| k₁ : ks' -> do
+                    WithLabel k₀ :| k₁ : ks' -> do
                         let e₁ =
                                 case Dhall.Map.lookup k₀ kvs of
                                     Nothing -> RecordLit mempty
@@ -709,6 +710,23 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                         e₂ <- loop (With e₁ (k₁ :| ks') v')
 
                         return (RecordLit (Dhall.Map.insert k₀ (Syntax.makeRecordField e₂) kvs))
+                    WithQuestion :| _ -> do
+                        return (With e' ks v')
+            Some t ->
+                case ks of
+                    WithQuestion :| [] -> do
+                        return (Some v')
+                    WithQuestion :| k : ks' -> do
+                        w <- loop (With t (k :| ks') v)
+                        return (Some w)
+                    WithLabel _ :| _ ->
+                        return (With e' ks v')
+            App None _T ->
+                case ks of
+                    WithQuestion :| _ ->
+                        return (App None _T)
+                    WithLabel _ :| _ ->
+                        return (With e' ks v')
             _ ->
                 return (With e' ks v')
     Note _ e' -> loop e'

dhall/src/Dhall/Parser/Expression.hs

@@ -388,7 +388,11 @@ parsers embedded = Parsers{..}
                     bs <- some (do
                         try (nonemptyWhitespace *> _with *> nonemptyWhitespace)
 
-                        keys <- Combinators.NonEmpty.sepBy1 anyLabelOrSome (try (whitespace *> _dot) *> whitespace)
+                        let withComponent =
+                                    fmap WithLabel anyLabelOrSome
+                                <|> fmap (\_ -> WithQuestion) (text "?")
+
+                        keys <- Combinators.NonEmpty.sepBy1 withComponent (try (whitespace *> _dot) *> whitespace)
 
                         whitespace
 

dhall/src/Dhall/Pretty/Internal.hs

@@ -513,7 +513,7 @@ escapeLabel :: Bool -> Text -> Text
 escapeLabel allowReserved l =
     case Text.uncons l of
         Just (h, t)
-            | headCharacter h && Text.all tailCharacter t && (notReservedIdentifier || (allowReserved && someOrNotLanguageKeyword))
+            | headCharacter h && Text.all tailCharacter t && (notReservedIdentifier || (allowReserved && someOrNotLanguageKeyword)) && l /= "?"
                 -> l
         _       -> "`" <> l <> "`"
     where
@@ -829,7 +829,11 @@ prettyPrinters characterSet =
             <>  Pretty.align (keyword "with" <> " " <> update)
 
         (update, _) =
-            prettyKeyValue prettyOperatorExpression equals (makeKeyValue b c)
+            prettyKeyValue prettyOperatorExpression equals
+                (makeKeyValue (fmap toText b) c)
+
+        toText  WithQuestion  = "?"
+        toText (WithLabel k ) = k
     prettyExpression (Assert a) =
         Pretty.group (Pretty.flatAlt long short)
       where

dhall/src/Dhall/Syntax.hs

@@ -37,6 +37,7 @@ module Dhall.Syntax (
     , makeFunctionBinding
     , FieldSelection(..)
     , makeFieldSelection
+    , WithComponent(..)
 
     -- ** 'Let'-blocks
     , MultiLet(..)
@@ -79,9 +80,6 @@ module Dhall.Syntax (
     , linesLiteral
     , unlinesLiteral
 
-    -- * Desugaring
-    , desugarWith
-
     -- * Utilities
     , internalError
     -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a
@@ -118,7 +116,6 @@ import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Text
 import qualified Data.Time          as Time
 import qualified Dhall.Crypto
-import qualified Dhall.Optics       as Optics
 import qualified Lens.Family        as Lens
 import qualified Network.URI        as URI
 import qualified Prettyprinter      as Pretty
@@ -429,6 +426,10 @@ data FieldSelection s = FieldSelection
 makeFieldSelection :: Text -> FieldSelection s
 makeFieldSelection t = FieldSelection Nothing t Nothing
 
+-- | A path component for a @with@ expression
+data WithComponent = WithLabel Text | WithQuestion
+    deriving (Data, Eq, Generic, Lift, NFData, Ord, Show)
+
 {-| Syntax tree for expressions
 
     The @s@ type parameter is used to track the presence or absence of `Src`
@@ -644,7 +645,7 @@ data Expr s a
     -- | > Equivalent _ x y                           ~  x ≡ y
     | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a)
     -- | > With x y e                               ~  x with y = e
-    | With (Expr s a) (NonEmpty Text) (Expr s a)
+    | With (Expr s a) (NonEmpty WithComponent) (Expr s a)
     -- | > Note s x                                 ~  e
     | Note s (Expr s a)
     -- | > ImportAlt                                ~  e1 ? e2
@@ -1464,30 +1465,6 @@ shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) =
     r'  =             shift d (V x n)  r
 shift d v expression = Lens.over subExpressions (shift d v) expression
 
--- | Desugar all @with@ expressions
-desugarWith :: Expr s a -> Expr s a
-desugarWith = Optics.rewriteOf subExpressions rewrite
-  where
-    rewrite e@(With record (key :| []) value) =
-        Just
-            (Prefer
-                mempty
-                (PreferFromWith e)
-                record
-                (RecordLit [ (key, makeRecordField value) ])
-            )
-    rewrite e@(With record (key0 :| key1 : keys) value) =
-        Just
-            (Let
-                (makeBinding "_" record)
-                (Prefer mempty (PreferFromWith e) "_"
-                    (RecordLit
-                        [ (key0, makeRecordField $ With (Field "_" (FieldSelection Nothing key0 Nothing)) (key1 :| keys) (shift 1 "_" value)) ]
-                    )
-                )
-            )
-    rewrite _ = Nothing
-
 _ERROR :: String
 _ERROR = "\ESC[1;31mError\ESC[0m"