From c2cc64140820b4d354e75156ae84124cab273f93 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Thu, 8 Aug 2019 16:36:01 +0200 Subject: [PATCH] Implement missing rules for field selection normalization (#1179) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit …as standardized in https://github.com/dhall-lang/dhall-lang/pull/682. --- dhall/dhall-lang | 2 +- dhall/src/Dhall/Core.hs | 18 ++++++++++++------ dhall/src/Dhall/Eval.hs | 12 +++++++++--- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/dhall/dhall-lang b/dhall/dhall-lang index b08bfa0..c465bb9 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit b08bfa062e2373d1cafaadfb75661e30f4caa91e +Subproject commit c465bb9b50b66bbd413837814f000df95752ff80 diff --git a/dhall/src/Dhall/Core.hs b/dhall/src/Dhall/Core.hs index 3e78efd..042e527 100644 --- a/dhall/src/Dhall/Core.hs +++ b/dhall/src/Dhall/Core.hs @@ -1752,6 +1752,8 @@ normalizeWithM ctx e0 = loop (denote e0) _ -> do return (ToMap x' t') Field r x -> do + let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v) + r' <- loop r case r' of RecordLit kvs -> @@ -1759,14 +1761,18 @@ normalizeWithM ctx e0 = loop (denote e0) Just v -> pure v Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x Project r_ _ -> loop (Field r_ x) + Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x) + Nothing -> loop (Field r_ x) Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of Just v -> pure v Nothing -> loop (Field l x) - Prefer (RecordLit kvs) r_ | not (Dhall.Map.member x kvs) -> loop (Field r_ x) + Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Combine (singletonRecordLit v) r_) x) + Nothing -> loop (Field r_ x) Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Combine l (RecordLit (Dhall.Map.singleton x v))) x) + Just v -> pure (Field (Combine l (singletonRecordLit v)) x) Nothing -> loop (Field l x) - Combine (RecordLit kvs) r_ | not (Dhall.Map.member x kvs) -> loop (Field r_ x) _ -> pure (Field r' x) Project r (Left xs)-> do r' <- loop r @@ -2017,10 +2023,10 @@ isNormalized e0 = loop (denote e0) Field r k -> case r of RecordLit _ -> False Project _ _ -> False - Combine (RecordLit m) _ -> Dhall.Map.member k m && loop r - Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r - Prefer (RecordLit m) _ -> Dhall.Map.member k m && loop r + Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r Prefer _ (RecordLit _) -> False + Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r + Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r _ -> loop r Project r p -> loop r && case p of diff --git a/dhall/src/Dhall/Eval.hs b/dhall/src/Dhall/Eval.hs index e18b871..57d448b 100644 --- a/dhall/src/Dhall/Eval.hs +++ b/dhall/src/Dhall/Eval.hs @@ -311,15 +311,21 @@ vField t0 k = go t0 where | Just v <- Dhall.Map.lookup k m -> v | otherwise -> error errorMsg VProject t _ -> go t + VPrefer (VRecordLit m) r -> case Dhall.Map.lookup k m of + Just v -> VField (VPrefer (singletonVRecordLit v) r) k + Nothing -> go r VPrefer l (VRecordLit m) -> case Dhall.Map.lookup k m of Just v -> v Nothing -> go l - VPrefer (VRecordLit m) r | not (Dhall.Map.member k m) -> go r + VCombine (VRecordLit m) r -> case Dhall.Map.lookup k m of + Just v -> VField (VCombine (singletonVRecordLit v) r) k + Nothing -> go r VCombine l (VRecordLit m) -> case Dhall.Map.lookup k m of - Just v -> VField (VCombine l (VRecordLit (Dhall.Map.singleton k v))) k + Just v -> VField (VCombine l (singletonVRecordLit v)) k Nothing -> go l - VCombine (VRecordLit m) r | not (Dhall.Map.member k m) -> go r t -> VField t k + + singletonVRecordLit v = VRecordLit (Dhall.Map.singleton k v) {-# inline vField #-} eval :: forall a. Eq a => Env a -> Expr Void a -> Val a