Skip to content

Commit e497101

Browse files
Gabriella439Gabriella439
authored
Add dhall-json support for unions as keys (#1094)
This is inspired by this StackOverflow question: https://stackoverflow.com/questions/56967374/dynamic-records-key-type
1 parent e0bd21e commit e497101

File tree

3 files changed

+91
-23
lines changed

3 files changed

+91
-23
lines changed

‎dhall-json/src/Dhall/JSON.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -703,6 +703,9 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
703703
Core.TextLit (Core.Chunks [] keyText) ->
704704
return keyText
705705

706+
Core.Field (Core.Union _) keyText ->
707+
return keyText
708+
706709
_ ->
707710
empty
708711

‎dhall-json/src/Dhall/JSONToDhall.hs

Lines changed: 23 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -102,6 +102,11 @@
102102
> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
103103
> [ { mapKey = "foo", mapValue = "bar" } ]
104104
105+
The map keys can even be union types instead of `Text`:
106+
107+
> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{"A": 1, "B": 2}'
108+
> [ { mapKey = < A | B >.A, mapValue = 1 }, { mapKey = < A | B >.B, mapValue = 2 } ]
109+
105110
Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it):
106111
107112
> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
@@ -424,19 +429,28 @@ dhallFromJSON (Conversion {..}) expressionType =
424429
loop t@(App D.List (D.Record r)) v@(A.Object o)
425430
| not noKeyValMap
426431
, ["mapKey", "mapValue"] == Map.keys r
427-
, Just D.Text == Map.lookup "mapKey" r
432+
, Just mapKey <- Map.lookup "mapKey" r
428433
, Just mapValue <- Map.lookup "mapValue" r
429-
, keyExprMap :: Either CompileError (HM.HashMap Text ExprX)
430-
<- traverse (loop mapValue) o
431-
= let f :: (Text, ExprX) -> ExprX
434+
= do
435+
keyExprMap <- traverse (loop mapValue) o
436+
437+
toKey <- do
438+
case mapKey of
439+
D.Text -> return (\key -> D.TextLit (Chunks [] key))
440+
D.Union _ -> return (\key -> D.Field mapKey key)
441+
_ -> Left (Mismatch t v)
442+
443+
let f :: (Text, ExprX) -> ExprX
432444
f (key, val) = D.RecordLit ( Map.fromList
433-
[ ("mapKey" , D.TextLit (Chunks [] key))
445+
[ ("mapKey" , toKey key)
434446
, ("mapValue", val)
435447
] )
436-
recs :: Either CompileError (Dhall.Seq ExprX)
437-
recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap
438-
typeAnn = if HM.null o then Just mapValue else Nothing
439-
in D.ListLit typeAnn <$> recs
448+
449+
let records = (fmap f . Seq.fromList . HM.toList) keyExprMap
450+
451+
let typeAnn = if HM.null o then Just mapValue else Nothing
452+
453+
return (D.ListLit typeAnn records)
440454
| noKeyValMap
441455
= Left (NoKeyValMap t v)
442456
| otherwise

‎dhall-json/tasty/Main.hs

Lines changed: 65 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@ module Main where
77
import Dhall.JSON (Conversion(..))
88
import Test.Tasty (TestTree)
99

10-
import qualified Control.Exception
11-
import qualified Data.Aeson
10+
import qualified Control.Exception as Exception
11+
import qualified Data.Aeson as Aeson
1212
import qualified Data.ByteString.Lazy
1313
import qualified Data.Text
1414
import qualified Data.Text.IO
@@ -32,6 +32,7 @@ testTree =
3232
, yaml
3333
, emptyAlternative
3434
, nesting
35+
, unionKeys
3536
]
3637

3738
issue48 :: TestTree
@@ -43,7 +44,7 @@ issue48 = Test.Tasty.HUnit.testCase "Issue #48" assertion
4344
code <- Data.Text.IO.readFile file
4445

4546
parsedExpression <- case Dhall.Parser.exprFromText file code of
46-
Left exception -> Control.Exception.throwIO exception
47+
Left exception -> Exception.throwIO exception
4748
Right parsedExpression -> return parsedExpression
4849

4950
resolvedExpression <- Dhall.Import.load parsedExpression
@@ -56,12 +57,12 @@ issue48 = Test.Tasty.HUnit.testCase "Issue #48" assertion
5657
Dhall.JSON.convertToHomogeneousMaps conversion resolvedExpression
5758

5859
actualValue <- case Dhall.JSON.dhallToJSON convertedExpression of
59-
Left exception -> Control.Exception.throwIO exception
60+
Left exception -> Exception.throwIO exception
6061
Right actualValue -> return actualValue
6162

6263
bytes <- Data.ByteString.Lazy.readFile "./tasty/data/issue48.json"
6364

64-
expectedValue <- case Data.Aeson.eitherDecode bytes of
65+
expectedValue <- case Aeson.eitherDecode bytes of
6566
Left string -> fail string
6667
Right expectedValue -> return expectedValue
6768

@@ -117,7 +118,7 @@ emptyAlternative :: TestTree
117118
emptyAlternative = Test.Tasty.HUnit.testCase "Empty alternative" $ do
118119
let schema = Core.Union [ ("Bar", Nothing), ("Foo", Nothing) ]
119120

120-
let json = Data.Aeson.String "Foo"
121+
let json = Aeson.String "Foo"
121122

122123
let expectedResult = Core.Field schema "Foo"
123124

@@ -132,17 +133,17 @@ nesting = Test.Tasty.testGroup "Nesting" [ nested, inline ]
132133
where
133134
nested =
134135
testCase "./tasty/data/nesting0.dhall"
135-
(Data.Aeson.Object
136-
[ ("foo", Data.Aeson.Number 2)
137-
, ("name", Data.Aeson.String "Left")
136+
(Aeson.Object
137+
[ ("foo", Aeson.Number 2)
138+
, ("name", Aeson.String "Left")
138139
]
139140
)
140141

141142
inline =
142143
testCase "./tasty/data/nesting1.dhall"
143-
(Data.Aeson.Object
144-
[ ("name", Data.Aeson.String "Left")
145-
, ("value", Data.Aeson.Object [ ("foo", Data.Aeson.Number 2 )] )
144+
(Aeson.Object
145+
[ ("name", Aeson.String "Left")
146+
, ("value", Aeson.Object [ ("foo", Aeson.Number 2 )] )
146147
]
147148
)
148149

@@ -151,7 +152,7 @@ nesting = Test.Tasty.testGroup "Nesting" [ nested, inline ]
151152
code <- Data.Text.IO.readFile file
152153

153154
parsedExpression <- case Dhall.Parser.exprFromText file code of
154-
Left exception -> Control.Exception.throwIO exception
155+
Left exception -> Exception.throwIO exception
155156
Right parsedExpression -> return parsedExpression
156157

157158
resolvedExpression <- Dhall.Import.load parsedExpression
@@ -164,9 +165,59 @@ nesting = Test.Tasty.testGroup "Nesting" [ nested, inline ]
164165
Dhall.JSON.convertToHomogeneousMaps conversion resolvedExpression
165166

166167
actualValue <- case Dhall.JSON.dhallToJSON convertedExpression of
167-
Left exception -> Control.Exception.throwIO exception
168+
Left exception -> Exception.throwIO exception
168169
Right actualValue -> return actualValue
169170

170171
let message = "The alternative name was not nested correctly"
171172

172173
Test.Tasty.HUnit.assertEqual message expectedValue actualValue
174+
175+
unionKeys :: TestTree
176+
unionKeys = Test.Tasty.HUnit.testCase "Empty alternative" $ do
177+
let union = Core.Union [ ("A", Nothing), ("B", Nothing) ]
178+
let schema =
179+
Core.App
180+
Core.List
181+
(Core.Record
182+
[ ("mapKey" , union )
183+
, ("mapValue", Core.Natural)
184+
]
185+
)
186+
187+
let expectedValue =
188+
Aeson.Object [ ("A", Aeson.Number 1), ("B", Aeson.Number 2) ]
189+
190+
let expectedDhall =
191+
Core.ListLit
192+
Nothing
193+
[ Core.RecordLit
194+
[ ("mapKey" , Core.Field union "A")
195+
, ("mapValue", Core.NaturalLit 1 )
196+
]
197+
, Core.RecordLit
198+
[ ("mapKey" , Core.Field union "B")
199+
, ("mapValue", Core.NaturalLit 2 )
200+
]
201+
]
202+
203+
actualDhall <- Core.throws (JSONToDhall.dhallFromJSON JSONToDhall.defaultConversion schema expectedValue)
204+
205+
let message₀ = "Union keys were not decoded from JSON correctly"
206+
207+
Test.Tasty.HUnit.assertEqual message₀ expectedDhall actualDhall
208+
209+
let mapKey = "mapKey"
210+
211+
let mapValue = "mapValue"
212+
213+
let conversion = Dhall.JSON.Conversion {..}
214+
215+
let convertedExpression =
216+
Dhall.JSON.convertToHomogeneousMaps conversion expectedDhall
217+
218+
let message₁ = "Union keys were not encoded as JSON correctly"
219+
220+
case Dhall.JSON.dhallToJSON convertedExpression of
221+
Left exception -> Exception.throwIO exception
222+
Right actualValue ->
223+
Test.Tasty.HUnit.assertEqual message₁ expectedValue actualValue

0 commit comments

Comments
 (0)