Simplify ⫽ within projection (#1283)

… as standardized in https://github.com/dhall-lang/dhall-lang/pull/697.

dhall/src/Dhall/Core.hs

@@ -113,6 +113,7 @@ import {-# SOURCE #-} qualified Dhall.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 Dhall.Map
@@ -1810,13 +1811,19 @@ normalizeWithM ctx e0 = loop (denote e0)
                 Just v -> pure (Field (Combine l (singletonRecordLit v)) x)
                 Nothing -> loop (Field l x)
             _ -> pure (Field r' x)
-    Project r (Left xs)-> do
+    Project x (Left fields)-> do
-        r' <- loop r
+        x' <- loop x
-        case r' of
+        let fieldsSet = Dhall.Set.toSet fields
+        case x' of
             RecordLit kvs ->
-                pure (RecordLit (Dhall.Map.restrictKeys kvs (Dhall.Set.toSet xs)))
+                pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))
-            _   | null xs -> pure (RecordLit mempty)
+            Prefer l (RecordLit rKvs) -> do
-                | otherwise -> pure (Project r' (Left (Dhall.Set.sort xs)))
+                let rKs = Dhall.Map.keysSet rKvs
+                let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs)))
+                let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet)
+                loop (Prefer l' r')
+            _ | null fields -> pure (RecordLit mempty)
+              | otherwise   -> pure (Project x' (Left (Dhall.Set.sort fields)))
     Project r (Right e1) -> do
         e2 <- loop e1
 
@@ -2065,6 +2072,7 @@ isNormalized e0 = loop (denote e0)
           case p of
               Left s -> case r of
                   RecordLit _ -> False
+                  Prefer _ (RecordLit _) -> False
                   _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s
               Right e' -> case e' of
                   Record _ -> False

dhall/src/Dhall/Eval.hs

@@ -84,6 +84,7 @@ import Unsafe.Coerce (unsafeCoerce)
 import qualified Codec.Serialise     as Serialise
 import qualified Data.Char
 import qualified Data.Sequence
+import qualified Data.Set
 import qualified Data.Text
 import qualified Dhall.Binary
 import qualified Dhall.Map
@@ -269,6 +270,16 @@ vApp !t !u = case t of
   t           -> VApp t u
 {-# inline vApp #-}
 
+vPrefer :: Eq a => Env a -> Val a -> Val a -> Val a
+vPrefer env t u = case (t, u) of
+  (VRecordLit m, u) | null m -> u
+  (t, VRecordLit m) | null m -> t
+  (VRecordLit m, VRecordLit m') ->
+     VRecordLit (Dhall.Map.union m' m)
+  (t, u) | conv env t u -> t
+  (t, u) -> VPrefer t u
+{-# inline vPrefer #-}
+
 vCombine :: Val a -> Val a -> Val a
 vCombine t u = case (t, u) of
   (VRecordLit m, u) | null m    -> u
@@ -327,6 +338,21 @@ vField t0 k = go t0 where
   singletonVRecordLit v = VRecordLit (Dhall.Map.singleton k v)
 {-# inline vField #-}
 
+vProjectByFields :: Eq a => Env a -> Val a -> Set Text -> Val a
+vProjectByFields env t ks =
+  if null ks then
+    VRecordLit mempty
+  else case t of
+    VRecordLit kvs -> let
+      kvs' = Dhall.Map.restrictKeys kvs (Dhall.Set.toSet ks)
+      in VRecordLit kvs'
+    VPrefer l r@(VRecordLit kvs) -> let
+      ksSet = Dhall.Set.toSet ks
+      kvs' = Dhall.Map.restrictKeys kvs ksSet
+      ks' = Dhall.Set.fromSet (Data.Set.difference ksSet (Dhall.Map.keysSet kvs'))
+      in vPrefer env (vProjectByFields env l ks') (VRecordLit kvs')
+    t -> VProject t (Left ks)
+
 eval :: forall a. Eq a => Env a -> Expr Void a -> Val a
 eval !env t =
   let
@@ -555,13 +581,7 @@ eval !env t =
     Union kts        -> VUnion (Dhall.Map.sort ((evalE <$>) <$> kts))
     Combine t u      -> vCombine (evalE t) (evalE u)
     CombineTypes t u -> vCombineTypes (evalE t) (evalE u)
-    Prefer t u       -> case (evalE t, evalE u) of
+    Prefer t u       -> vPrefer env (evalE t) (evalE u)
-                          (VRecordLit m, u) | null m -> u
-                          (t, VRecordLit m) | null m -> t
-                          (VRecordLit m, VRecordLit m') ->
-                             VRecordLit (Dhall.Map.union m' m)
-                          (t, u) | conv env t u -> t
-                          (t, u) -> VPrefer t u
     Merge x y ma     -> case (evalE x, evalE y, evalE <$> ma) of
                           (VRecordLit m, VInject _ k mt, _)
                             | Just f  <- Dhall.Map.lookup k m -> maybe f (vApp f) mt
@@ -578,14 +598,7 @@ eval !env t =
                             in VListLit Nothing s
                           (x, ma) -> VToMap x ma
     Field t k        -> vField (evalE t) k
-    Project t (Left ks) ->
+    Project t (Left ks) -> vProjectByFields env (evalE t) (Dhall.Set.sort ks)
-                        if null ks then
-                          VRecordLit mempty
-                        else case evalE t of
-                          VRecordLit kvs -> let
-                            kvs' = Dhall.Map.restrictKeys kvs (Dhall.Set.toSet ks)
-                            in VRecordLit kvs'
-                          t -> VProject t (Left (Dhall.Set.sort ks))
     Project t (Right e) ->
                         case evalE e of
                           VRecord kts ->