Skip to content

Commit 1d58840

Browse files
sjakobisjakobi
authored
dhall-json: Nesting: Support empty alternatives as contents (#1204)
Closes #1201.
1 parent d66d1db commit 1d58840

File tree

6 files changed

+82
-39
lines changed

6 files changed

+82
-39
lines changed

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

+62-39
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE OverloadedLists #-}
22
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE PatternGuards #-}
34
{-# LANGUAGE PatternSynonyms #-}
45
{-# LANGUAGE RecordWildCards #-}
56

@@ -116,7 +117,7 @@
116117
> "name": "Left"
117118
> }
118119
119-
If @nesting@ is set to @Nested nestedField@ then the union is store
120+
If @nesting@ is set to @Nested nestedField@ then the union is stored
120121
underneath a field named @nestedField@. For example, this code:
121122
122123
> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
@@ -191,11 +192,13 @@ import Dhall.TypeCheck (X)
191192
import Dhall.Map (Map)
192193
import Dhall.JSON.Util (pattern V)
193194
import Options.Applicative (Parser)
195+
import Prelude hiding (getContents)
194196

195197
import qualified Data.Aeson as Aeson
196198
import qualified Data.Foldable as Foldable
197199
import qualified Data.HashMap.Strict as HashMap
198200
import qualified Data.List
201+
import qualified Data.Map
199202
import qualified Data.Ord
200203
import qualified Data.Text
201204
import qualified Data.Vector as Vector
@@ -319,12 +322,7 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
319322
Core.RecordLit a ->
320323
case toOrderedList a of
321324
[ ( "contents"
322-
, Core.App
323-
(Core.Field
324-
_
325-
alternativeName
326-
)
327-
contents
325+
, contents
328326
)
329327
, ( "field"
330328
, Core.TextLit
@@ -344,28 +342,26 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
344342
(Core.Chunks [] nestedField)
345343
)
346344
)
347-
] | all (== Core.Record []) mInlineType -> do
348-
contents' <- loop contents
349-
350-
let taggedValue =
351-
Dhall.Map.fromList
352-
[ ( field
353-
, toJSON alternativeName
354-
)
355-
, ( nestedField
356-
, contents'
357-
)
358-
]
359-
360-
return (Aeson.toJSON ( Dhall.Map.toMap taggedValue ))
345+
] | all (== Core.Record []) mInlineType
346+
, Just (alternativeName, mExpr) <- getContents contents -> do
347+
contents' <- case mExpr of
348+
Just expr -> loop expr
349+
Nothing -> return Aeson.Null
350+
351+
let taggedValue =
352+
Data.Map.fromList
353+
[ ( field
354+
, toJSON alternativeName
355+
)
356+
, ( nestedField
357+
, contents'
358+
)
359+
]
360+
361+
return (Aeson.toJSON taggedValue)
361362

362363
[ ( "contents"
363-
, Core.App
364-
(Core.Field
365-
_
366-
alternativeName
367-
)
368-
(Core.RecordLit contents)
364+
, contents
369365
)
370366
, ( "field"
371367
, Core.TextLit
@@ -374,19 +370,35 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
374370
, ( "nesting"
375371
, nesting
376372
)
377-
] | isInlineNesting nesting -> do
378-
let contents' =
379-
Dhall.Map.insert
380-
field
381-
(Core.TextLit
382-
(Core.Chunks
383-
[]
384-
alternativeName
385-
)
386-
)
387-
contents
373+
] | isInlineNesting nesting
374+
, Just (alternativeName, Just (Core.RecordLit kvs)) <- getContents contents -> do
375+
let kvs' =
376+
Dhall.Map.insert
377+
field
378+
(Core.TextLit
379+
(Core.Chunks
380+
[]
381+
alternativeName
382+
)
383+
)
384+
kvs
385+
386+
loop (Core.RecordLit kvs')
387+
388+
| isInlineNesting nesting
389+
, Just (alternativeName, Nothing) <- getContents contents -> do
390+
let kvs =
391+
Dhall.Map.singleton
392+
field
393+
(Core.TextLit
394+
(Core.Chunks
395+
[]
396+
alternativeName
397+
)
398+
)
399+
400+
loop (Core.RecordLit kvs)
388401

389-
loop (Core.RecordLit contents')
390402
_ -> do
391403
a' <- traverse loop a
392404
return (Aeson.toJSON (Dhall.Map.toMap a'))
@@ -432,6 +444,17 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
432444
outer value
433445
_ -> Left (Unsupported e)
434446

447+
getContents :: Expr s X -> Maybe (Text, Maybe (Expr s X))
448+
getContents (Core.App
449+
(Core.Field
450+
_
451+
alternativeName
452+
)
453+
expression
454+
) = Just (alternativeName, Just expression)
455+
getContents (Core.Field _ alternativeName) = Just (alternativeName, Nothing)
456+
getContents _ = Nothing
457+
435458
isInlineNesting :: Expr s X -> Bool
436459
isInlineNesting (Core.App
437460
(Core.Field

‎dhall-json/tasty/Main.hs

+2
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,8 @@ testTree =
3939
, Test.Tasty.testGroup "Nesting"
4040
[ testDhallToJSON "./tasty/data/nesting0"
4141
, testDhallToJSON "./tasty/data/nesting1"
42+
, testDhallToJSON "./tasty/data/nesting2"
43+
, testDhallToJSON "./tasty/data/nesting3"
4244
, testDhallToJSON "./tasty/data/nestingLegacy0"
4345
, testDhallToJSON "./tasty/data/nestingLegacy1"
4446
]

‎dhall-json/tasty/data/nesting2.dhall

+8
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
let Example = < Left : { foo : Natural } | Middle | Right : { bar : Bool } >
2+
3+
let Nesting = < Inline | Nested : Text >
4+
5+
in { field = "name"
6+
, nesting = Nesting.Inline
7+
, contents = Example.Middle
8+
}

‎dhall-json/tasty/data/nesting2.json

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
{ "name": "Middle" }

‎dhall-json/tasty/data/nesting3.dhall

+8
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
let Example = < Left : { foo : Natural } | Middle | Right : { bar : Bool } >
2+
3+
let Nesting = < Inline | Nested : Text >
4+
5+
in { field = "name"
6+
, nesting = Nesting.Nested "value"
7+
, contents = Example.Middle
8+
}

‎dhall-json/tasty/data/nesting3.json

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
{ "name": "Middle", "value": null }

0 commit comments

Comments
 (0)