Implement with keyword

dhall-bash/src/Dhall/Bash.hs

@@ -335,6 +335,7 @@ dhallToStatement expr0 var0 = go (Dhall.Core.normalize expr0)
     go e@(Project          {}) = Left (UnsupportedStatement e)
     go e@(Assert           {}) = Left (UnsupportedStatement e)
     go e@(Equivalent       {}) = Left (UnsupportedStatement e)
+    go e@(With             {}) = Left (UnsupportedStatement e)
     go e@(ImportAlt        {}) = Left (UnsupportedStatement e)
 
 {-| Compile a Dhall expression to a Bash expression

dhall-json/src/Dhall/JSON.hs

@@ -996,11 +996,11 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
             a' = loop a
             b' = loop b
 
-        Core.Prefer a b ->
-            Core.Prefer a' b'
+        Core.Prefer a b c ->
+            Core.Prefer a b' c'
           where
-            a' = loop a
             b' = loop b
+            c' = loop c
 
         Core.RecordCompletion a b ->
             Core.RecordCompletion a' b'
@@ -1042,6 +1042,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
             a' = loop a
             b' = loop b
 
+        Core.With a b c ->
+            Core.With a' b c'
+          where
+            a' = loop a
+            c' = loop c
+
         Core.ImportAlt a b ->
             Core.ImportAlt a' b'
           where

dhall-nix/src/Dhall/Nix.hs

@@ -96,7 +96,15 @@ import Data.Fix (Fix(..))
 import Data.Traversable (for)
 import Data.Typeable (Typeable)
 import Data.Void (Void, absurd)
-import Dhall.Core (Chunks(..), Const(..), DhallDouble(..), Expr(..), MultiLet(..), Var(..))
+import Dhall.Core
+    ( Chunks(..)
+    , Const(..)
+    , DhallDouble(..)
+    , Expr(..)
+    , MultiLet(..)
+    , PreferAnnotation(..)
+    , Var(..)
+    )
 import Nix.Atoms (NAtom(..))
 import Nix.Expr
     ( Antiquoted(..)
@@ -522,12 +530,12 @@ dhallToNix e = loop (Dhall.Core.normalize e)
         let map_ = Fix (NBinary NApp "map" (Fix (NAbs "k" (Fix (NSet NNonRecursive setBindings)))))
         let toMap = Fix (NAbs "kvs" (Fix (NBinary NApp map_ ks)))
         return (Fix (NBinary NApp toMap a'))
-    loop (Prefer a b) = do
-        a' <- loop a
+    loop (Prefer _ b c) = do
         b' <- loop b
-        return (Fix (NBinary NUpdate a' b'))
+        c' <- loop c
+        return (Fix (NBinary NUpdate b' c'))
     loop (RecordCompletion a b) = do
-        loop (Annot (Prefer (Field a "default") b) (Field a "Type"))
+        loop (Annot (Prefer PreferFromCompletion (Field a "default") b) (Field a "Type"))
     loop (Field (Union kts) k) =
         case Dhall.Map.lookup k kts of
             -- If the selected alternative has an associated payload, then we
@@ -561,6 +569,8 @@ dhallToNix e = loop (Dhall.Core.normalize e)
         return untranslatable
     loop (Equivalent _ _) = do
         return untranslatable
+    loop a@With{} = do
+        loop (Dhall.Core.desugarWith a)
     loop (ImportAlt a _) = loop a
     loop (Note _ b) = loop b
     loop (Embed x) = absurd x

dhall/benchmark/deep-nested-large-record/Main.hs

@@ -50,7 +50,7 @@ unionPerformance prelude = Gauge.whnf TypeCheck.typeOf expr
                         Nothing
                         (prelude `Core.Field` "types" `Core.Field` "Big")
                     )
-                    (Core.Prefer "big" "big")
+                    (Core.Prefer Core.PreferFromSource "big" "big")
                 )
             )
             "x"

dhall/src/Dhall/Binary.hs

@@ -44,6 +44,7 @@ import Dhall.Syntax
     , ImportMode(..)
     , ImportType(..)
     , MultiLet(..)
+    , PreferAnnotation(..)
     , Scheme(..)
     , URL(..)
     , Var(..)
@@ -65,10 +66,10 @@ import qualified Data.ByteString
 import qualified Data.ByteString.Lazy
 import qualified Data.Sequence
 import qualified Data.Text            as Text
-import qualified Dhall.Syntax
 import qualified Dhall.Crypto
 import qualified Dhall.Map
 import qualified Dhall.Set
+import qualified Dhall.Syntax         as Syntax
 import qualified Text.Printf          as Printf
 
 {-| Supported version strings
@@ -306,7 +307,7 @@ decodeExpressionInternal decodeEmbed = go
                                     6  -> return TextAppend
                                     7  -> return ListAppend
                                     8  -> return (Combine Nothing)
-                                    9  -> return Prefer
+                                    9  -> return (Prefer PreferFromSource)
                                     10 -> return CombineTypes
                                     11 -> return ImportAlt
                                     12 -> return Equivalent
@@ -759,7 +760,7 @@ encodeExpressionInternal encodeEmbed = go
         Combine _ l r ->
             encodeOperator 8 l r
 
-        Prefer l r ->
+        Prefer _ l r ->
             encodeOperator 9 l r
 
         CombineTypes l r ->
@@ -910,7 +911,7 @@ encodeExpressionInternal encodeEmbed = go
                 : concatMap encodeBinding (toList as) ++ [ go b₁ ]
                 )
           where
-            MultiLet as b₁ = Dhall.Syntax.multiLet a₀ b₀
+            MultiLet as b₁ = Syntax.multiLet a₀ b₀
 
             encodeBinding (Binding _ x _ mA₀ _ a) =
                 [ Encoding.encodeString x
@@ -939,6 +940,9 @@ encodeExpressionInternal encodeEmbed = go
                 (go t)
                 (go _T)
 
+        a@With{} ->
+            go (Syntax.desugarWith a)
+
         Note _ b ->
             go b
 
@@ -1104,7 +1108,7 @@ encodeImport import_ =
                 Nothing ->
                     Encoding.encodeNull
                 Just h ->
-                    encodeExpressionInternal encodeImport (Dhall.Syntax.denote h)
+                    encodeExpressionInternal encodeImport (Syntax.denote h)
 
             scheme₁ = case scheme₀ of
                 HTTP  -> 0

dhall/src/Dhall/Core.hs

@@ -24,6 +24,7 @@ module Dhall.Core (
     , Binding(..)
     , makeBinding
     , Chunks(..)
+    , PreferAnnotation(..)
     , Expr(..)
 
     -- * Normalization
@@ -66,6 +67,7 @@ module Dhall.Core (
     , Eval.textShow
     , censorExpression
     , censorText
+    , Syntax.desugarWith
     ) where
 
 import Control.Exception (Exception)
@@ -82,8 +84,9 @@ import Lens.Family (over)
 import Prelude hiding (succ)
 
 import qualified Control.Exception
-import qualified Dhall.Eval    as Eval
 import qualified Data.Text
+import qualified Dhall.Eval        as Eval
+import qualified Dhall.Syntax      as Syntax
 
 -- | Pretty-print a value
 pretty :: Pretty a => a -> Text

dhall/src/Dhall/Diff.hs

@@ -31,15 +31,16 @@ import Dhall.Set (Set)
 import Dhall.Pretty.Internal (Ann)
 import Numeric.Natural (Natural)
 
-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.Text.Prettyprint.Doc  as Pretty
-import qualified Dhall.Normalize
+import qualified Data.Text.Prettyprint.Doc as Pretty
 import qualified Dhall.Map
+import qualified Dhall.Normalize           as Normalize
+import qualified Dhall.Pretty.Internal     as Internal
 import qualified Dhall.Set
-import qualified Dhall.Pretty.Internal      as Internal
+import qualified Dhall.Syntax              as Syntax
 
 {-| This type is a `Doc` enriched with a `same` flag to efficiently track if
     any difference was detected
@@ -158,8 +159,8 @@ rparen = token Internal.rparen
 diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff
 diffNormalized l0 r0 = Dhall.Diff.diff l1 r1
   where
-    l1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize l0)
-    r1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize r0)
+    l1 = Normalize.alphaNormalize (Normalize.normalize l0)
+    r1 = Normalize.alphaNormalize (Normalize.normalize r0)
 
 diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff
 diffPrimitive f l r
@@ -619,6 +620,12 @@ skeleton (Project {}) =
     <>  ignore
     <>  " "
     <>  rbrace
+skeleton (With {}) =
+         ignore
+    <>   " "
+    <>   keyword "with"
+    <>   " "
+    <>   ignore
 skeleton x = token (Pretty.pretty x)
 
 mismatch :: Pretty a => Expr s a -> Expr s a -> Diff
@@ -729,8 +736,8 @@ diffAnnotatedExpression (Merge aL bL cL) (Merge aR bR cR) = align doc
   where
     doc =   keyword "merge"
         <>  " "
-        <>  format " " (diffImportExpression aL aR)
-        <>  format " " (diffImportExpression bL bR)
+        <>  format " " (diffWithExpression aL aR)
+        <>  format " " (diffWithExpression bL bR)
         <>  diffMaybe (colon <> " ") diffApplicationExpression cL cR
 diffAnnotatedExpression l@(Merge {}) r =
     mismatch l r
@@ -740,7 +747,7 @@ diffAnnotatedExpression (ToMap aL bL) (ToMap aR bR) = align doc
   where
     doc =   keyword "toMap"
         <>  " "
-        <>  format " " (diffImportExpression aL aR)
+        <>  format " " (diffWithExpression aL aR)
         <>  diffMaybe (colon <> " ") diffApplicationExpression bL bR
 diffAnnotatedExpression l@(ToMap {}) r =
     mismatch l r
@@ -897,7 +904,7 @@ diffPreferExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff
 diffPreferExpression l@(Prefer {}) r@(Prefer {}) =
     enclosed' "  " (operator "⫽" <> " ") (docs l r)
   where
-    docs (Prefer aL bL) (Prefer aR bR) =
+    docs (Prefer _ aL bL) (Prefer _ aR bR) =
         Data.List.NonEmpty.cons (diffCombineTypesExpression aL aR) (docs bL bR)
     docs aL aR =
         pure (diffCombineTypesExpression aL aR)
@@ -989,26 +996,36 @@ diffApplicationExpression l@(App {}) r@(App {}) =
     enclosed' mempty mempty (Data.List.NonEmpty.reverse (docs l r))
   where
     docs (App aL bL) (App aR bR) =
-        Data.List.NonEmpty.cons (diffImportExpression bL bR) (docs aL aR)
+        Data.List.NonEmpty.cons (diffWithExpression bL bR) (docs aL aR)
     docs (Some aL) (Some aR) =
-        diffImportExpression aL aR :| [ builtin "Some" ]
+        diffWithExpression aL aR :| [ builtin "Some" ]
     docs aL aR@(Some {}) =
         pure (mismatch aL aR)
     docs aL@(Some {}) aR =
         pure (mismatch aL aR)
     docs aL aR =
-        pure (diffImportExpression aL aR)
+        pure (diffWithExpression aL aR)
 diffApplicationExpression l@(App {}) r =
     mismatch l r
 diffApplicationExpression l r@(App {}) =
     mismatch l r
 diffApplicationExpression (Some l) (Some r) =
-    enclosed' mempty mempty (builtin "Some" :| [ diffImportExpression l r ])
+    enclosed' mempty mempty (builtin "Some" :| [ diffWithExpression l r ])
 diffApplicationExpression l@(Some {}) r =
     mismatch l r
 diffApplicationExpression l r@(Some {}) =
     mismatch l r
 diffApplicationExpression l r =
+    diffWithExpression l r
+
+diffWithExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff
+diffWithExpression l@With{} r@With{} =
+    diffWithExpression (Syntax.desugarWith l) (Syntax.desugarWith r)
+diffWithExpression l r@With{} =
+    mismatch l r
+diffWithExpression l@With{} r =
+    mismatch l r
+diffWithExpression l r =
     diffImportExpression l r
 
 diffImportExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff

dhall/src/Dhall/Eval.hs

@@ -57,21 +57,21 @@ import Data.Semigroup (Semigroup(..))
 import Data.Sequence (Seq, ViewL(..), ViewR(..))
 import Data.Text (Text)
 import Data.Void (Void)
+import Dhall.Map (Map)
+import Dhall.Set (Set)
+import GHC.Natural (Natural)
+import Prelude hiding (succ)
 
 import Dhall.Syntax
   ( Binding(..)
   , Expr(..)
   , Chunks(..)
   , Const(..)
   , DhallDouble(..)
+  , PreferAnnotation(..)
   , Var(..)
   )
 
-import Dhall.Map (Map)
-import Dhall.Set (Set)
-import GHC.Natural (Natural)
-import Prelude hiding (succ)
-
 import qualified Data.Char
 import qualified Data.Sequence   as Sequence
 import qualified Data.Set
@@ -688,10 +688,10 @@ eval !env t0 =
             vCombine mk (eval env t) (eval env u)
         CombineTypes t u ->
             vCombineTypes (eval env t) (eval env u)
-        Prefer t u ->
+        Prefer _ t u ->
             vPrefer env (eval env t) (eval env u)
         RecordCompletion t u ->
-            eval env (Annot (Prefer (Field t "default") u) (Field t "Type"))
+            eval env (Annot (Prefer PreferFromCompletion (Field t "default") u) (Field t "Type"))
         Merge x y ma ->
             case (eval env x, eval env y, fmap (eval env) ma) of
                 (VRecordLit m, VInject _ k mt, _)
@@ -736,6 +736,8 @@ eval !env t0 =
             VAssert (eval env t)
         Equivalent t u ->
             VEquivalent (eval env t) (eval env u)
+        e@With{} ->
+            eval env (Syntax.desugarWith e)
         Note _ e ->
             eval env e
         ImportAlt t _ ->
@@ -1117,7 +1119,7 @@ quote !env !t0 =
         VCombineTypes t u ->
             CombineTypes (quote env t) (quote env u)
         VPrefer t u ->
-            Prefer (quote env t) (quote env u)
+            Prefer PreferFromSource (quote env t) (quote env u)
         VMerge t u ma ->
             Merge (quote env t) (quote env u) (fmap (quote env) ma)
         VToMap t ma ->
@@ -1296,8 +1298,8 @@ alphaNormalize = goEnv EmptyNames
                 Combine m (go t) (go u)
             CombineTypes t u ->
                 CombineTypes (go t) (go u)
-            Prefer t u ->
-                Prefer (go t) (go u)
+            Prefer b t u ->
+                Prefer b (go t) (go u)
             RecordCompletion t u ->
                 RecordCompletion (go t) (go u)
             Merge x y ma ->
@@ -1312,6 +1314,8 @@ alphaNormalize = goEnv EmptyNames
                 Assert (go t)
             Equivalent t u ->
                 Equivalent (go t) (go u)
+            With e k v ->
+                With (go e) k (go v)
             Note s e ->
                 Note s (go e)
             ImportAlt t u ->