Simplify ⫽ within projection (#1283)
… as standardized in https://github.com/dhall-lang/dhall-lang/pull/697.
This commit is contained in:
parent
65710954cf
commit
796680bb99
|
@ -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
|
||||
r' <- loop r
|
||||
case r' of
|
||||
Project x (Left fields)-> do
|
||||
x' <- loop x
|
||||
let fieldsSet = Dhall.Set.toSet fields
|
||||
case x' of
|
||||
RecordLit kvs ->
|
||||
pure (RecordLit (Dhall.Map.restrictKeys kvs (Dhall.Set.toSet xs)))
|
||||
_ | null xs -> pure (RecordLit mempty)
|
||||
| otherwise -> pure (Project r' (Left (Dhall.Set.sort xs)))
|
||||
pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))
|
||||
Prefer l (RecordLit rKvs) -> do
|
||||
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
|
||||
|
|
|
@ -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
|
||||
(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
|
||||
Prefer t u -> vPrefer env (evalE t) (evalE 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) ->
|
||||
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 (Left ks) -> vProjectByFields env (evalE t) (Dhall.Set.sort ks)
|
||||
Project t (Right e) ->
|
||||
case evalE e of
|
||||
VRecord kts ->
|
||||
|
|
Loading…
Reference in New Issue
Block a user