Skip to content

Commit a3ffd19

Browse files
Gabriella439Gabriella439
committed
Add support for accessing/projecting record type fields
… as standardized in dhall-lang/dhall-lang#1371
1 parent 44b9f30 commit a3ffd19

File tree

7 files changed

+71
-21
lines changed

7 files changed

+71
-21
lines changed

‎dhall/dhall-lang

Submodule dhall-lang updated 47 files

‎dhall/dhall.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -381,6 +381,7 @@ Library
381381
Dhall.Syntax.Instances.Functor
382382
Dhall.Syntax.Instances.Lift
383383
Dhall.Syntax.Instances.Monad
384+
Dhall.Syntax.Instances.Monoid
384385
Dhall.Syntax.Instances.NFData
385386
Dhall.Syntax.Instances.Ord
386387
Dhall.Syntax.Instances.Pretty

‎dhall/src/Dhall/Eval.hs

+6
Original file line numberDiff line numberDiff line change
@@ -367,6 +367,9 @@ vField t0 k = go t0
367367
Just (Just _) -> VPrim $ \ ~u -> VInject m k (Just u)
368368
Just Nothing -> VInject m k Nothing
369369
_ -> error errorMsg
370+
VRecord m
371+
| Just v <- Map.lookup k m -> v
372+
| otherwise -> error errorMsg
370373
VRecordLit m
371374
| Just v <- Map.lookup k m -> v
372375
| otherwise -> error errorMsg
@@ -414,6 +417,9 @@ vProjectByFields env t ks =
414417
VRecordLit kvs ->
415418
let kvs' = Map.restrictKeys kvs (Dhall.Set.toSet ks)
416419
in VRecordLit kvs'
420+
VRecord kTs ->
421+
let kTs' = Map.restrictKeys kTs (Dhall.Set.toSet ks)
422+
in VRecord kTs'
417423
VProject t' _ ->
418424
vProjectByFields env t' ks
419425
VPrefer l (VRecordLit kvs) ->

‎dhall/src/Dhall/Normalize.hs

+9
Original file line numberDiff line numberDiff line change
@@ -664,6 +664,11 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
664664
case Dhall.Map.lookup x kvs of
665665
Just v -> pure $ recordFieldValue v
666666
Nothing -> Field <$> (RecordLit <$> traverse (Syntax.recordFieldExprs loop) kvs) <*> pure k
667+
Record kTs ->
668+
case Dhall.Map.lookup x kTs of
669+
Just _T -> pure $ recordFieldValue _T
670+
Nothing -> Field <$> (Record <$> traverse (Syntax.recordFieldExprs loop) kTs) <*> pure k
671+
667672
Project r_ _ -> loop (Field r_ k)
668673
Prefer cs _ (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of
669674
Just v -> pure (Field (Prefer cs PreferFromSource (singletonRecordLit v) r_) k)
@@ -684,6 +689,8 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
684689
case x' of
685690
RecordLit kvs ->
686691
pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))
692+
Record kTs ->
693+
pure (Record (Dhall.Map.restrictKeys kTs fieldsSet))
687694
Project y _ ->
688695
loop (Project y (Left fields))
689696
Prefer cs _ l (RecordLit rKvs) -> do
@@ -980,6 +987,7 @@ isNormalized e0 = loop (Syntax.denote e0)
980987
_ -> True
981988
Field r (FieldSelection Nothing k Nothing) -> case r of
982989
RecordLit _ -> False
990+
Record _ -> False
983991
Project _ _ -> False
984992
Prefer _ _ (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r
985993
Prefer _ _ _ (RecordLit _) -> False
@@ -991,6 +999,7 @@ isNormalized e0 = loop (Syntax.denote e0)
991999
case p of
9921000
Left s -> case r of
9931001
RecordLit _ -> False
1002+
Record _ -> False
9941003
Project _ _ -> False
9951004
Prefer _ _ _ (RecordLit _) -> False
9961005
_ -> not (null s) && Data.Set.toList (Data.Set.fromList s) == s

‎dhall/src/Dhall/Syntax.hs

+1
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Dhall.Syntax.Instances.Foldable as Export ()
1919
import Dhall.Syntax.Instances.Functor as Export ()
2020
import Dhall.Syntax.Instances.Lift as Export ()
2121
import Dhall.Syntax.Instances.Monad as Export ()
22+
import Dhall.Syntax.Instances.Monoid as Export ()
2223
import Dhall.Syntax.Instances.NFData as Export ()
2324
import Dhall.Syntax.Instances.Ord as Export ()
2425
import Dhall.Syntax.Instances.Pretty as Export

‎dhall/src/Dhall/Syntax/Instances/Monoid.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
module Dhall.Syntax.Instances.Monoid () where
4+
5+
import Dhall.Syntax.Const (Const(..))
6+
import Dhall.Syntax.Instances.Ord ()
7+
8+
instance Semigroup Const where
9+
(<>) = max
10+
11+
instance Monoid Const where
12+
mempty = Type

‎dhall/src/Dhall/TypeCheck.hs

+41-20
Original file line numberDiff line numberDiff line change
@@ -1158,22 +1158,26 @@ infer typer = loop
11581158
case Dhall.Map.lookup x xTs' of
11591159
Just _T' -> return _T'
11601160
Nothing -> die (MissingField x _E'')
1161-
_ -> do
1162-
let e' = eval values e
1163-
1164-
let e'' = quote names e'
1165-
1166-
case e' of
1167-
VUnion xTs' ->
1168-
case Dhall.Map.lookup x xTs' of
1169-
Just (Just _T') -> return (VHPi x _T' (\_ -> e'))
1170-
Just Nothing -> return e'
1171-
Nothing -> die (MissingConstructor x e)
1172-
1173-
_ -> do
1174-
let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabel x)
1175-
1176-
die (CantAccess text e'' _E'')
1161+
_ | VRecord xTs' <- eval values e ->
1162+
case Dhall.Map.lookup x xTs' of
1163+
Just _T' -> loop ctx (quote names _T')
1164+
Nothing -> die (MissingField x _E'')
1165+
| otherwise -> do
1166+
let e' = eval values e
1167+
1168+
let e'' = quote names e'
1169+
1170+
case e' of
1171+
VUnion xTs' ->
1172+
case Dhall.Map.lookup x xTs' of
1173+
Just (Just _T') -> return (VHPi x _T' (\_ -> e'))
1174+
Just Nothing -> return e'
1175+
Nothing -> die (MissingConstructor x e)
1176+
1177+
_ -> do
1178+
let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabel x)
1179+
1180+
die (CantAccess text e'' _E'')
11771181
Project e (Left xs) -> do
11781182
case duplicateElement xs of
11791183
Just x -> do
@@ -1185,6 +1189,9 @@ infer typer = loop
11851189

11861190
let _E'' = quote names _E'
11871191

1192+
let text =
1193+
Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabels xs)
1194+
11881195
case _E' of
11891196
VRecord xTs' -> do
11901197
let process x =
@@ -1196,11 +1203,25 @@ infer typer = loop
11961203

11971204
fmap adapt (traverse process xs)
11981205

1199-
_ -> do
1200-
let text =
1201-
Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabels xs)
1206+
_ | VRecord xTs' <- eval values e -> do
1207+
let process x =
1208+
case Dhall.Map.lookup x xTs' of
1209+
Just _T' -> do
1210+
_T'' <- loop ctx (quote names _T')
1211+
1212+
case _T'' of
1213+
VConst c -> pure c
1214+
_ -> die (CantProject text e _E'')
1215+
1216+
Nothing -> do
1217+
die (MissingField x _E'')
1218+
1219+
cs <- traverse process xs
1220+
1221+
return (VConst (mconcat cs))
12021222

1203-
die (CantProject text e _E'')
1223+
| otherwise -> do
1224+
die (CantProject text e _E'')
12041225

12051226
Project e (Right s) -> do
12061227
_E' <- loop ctx e

0 commit comments

Comments
 (0)