Skip to content

Commit

Permalink
Throw error when union value is incompatible with Inline nesting (#1226)
Browse files Browse the repository at this point in the history
  • Loading branch information
@sjakobi @mergify
sjakobi authored and mergify[bot] committed Aug 20, 2019
1 parent 2c16750 commit 93711ae
Show file tree
Hide file tree
Showing 3 changed files with 106 additions and 38 deletions.
1 change: 1 addition & 0 deletions dhall-json/dhall-json.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ Library
exceptions >= 0.8.3 && < 0.11,
filepath < 1.5 ,
optparse-applicative >= 0.14.0.0 && < 0.16,
prettyprinter >= 1.2.0.1 && < 1.3 ,
scientific >= 0.3.0.0 && < 0.4 ,
text >= 0.11.1.0 && < 1.3 ,
unordered-containers < 0.3 ,
Expand Down
139 changes: 103 additions & 36 deletions dhall-json/src/Dhall/JSON.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -187,27 +187,32 @@ import Data.Aeson (Value(..), ToJSON(..))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty)
import Dhall.Core (Expr)
import Dhall.TypeCheck (X)
import Dhall.Map (Map)
import Dhall.JSON.Util (pattern V)
import Options.Applicative (Parser)
import Prelude hiding (getContents)

import qualified Data.Aeson as Aeson
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Aeson as Aeson
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List
import qualified Data.Map
import qualified Data.Ord
import qualified Data.Text
import qualified Data.Vector as Vector
import qualified Dhall.Core as Core
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Data.Vector as Vector
import qualified Dhall.Core as Core
import qualified Dhall.Import
import qualified Dhall.Map
import qualified Dhall.Optics
import qualified Dhall.Parser
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck
import qualified Dhall.Util
import qualified Options.Applicative
import qualified System.FilePath

Expand All @@ -221,6 +226,7 @@ data CompileError
= Unsupported (Expr X X)
| SpecialDouble Double
| BareNone
| InvalidInlineContents (Expr X X) (Expr X X)

instance Show CompileError where
show BareNone =
Expand Down Expand Up @@ -249,7 +255,7 @@ instance Show CompileError where

show (SpecialDouble n) =
Data.Text.unpack $
_ERROR <> ": " <> special <> " disallowed in JSON \n\
_ERROR <> ": " <> special <> " disallowed in JSON \n\
\ \n\
\Explanation: The JSON standard does not define a canonical way to encode \n\
\❰NaN❱/❰Infinity❱/❰-Infinity❱. You can fix this error by either: \n\
Expand All @@ -275,12 +281,88 @@ instance Show CompileError where
\ \n\
\The following Dhall expression could not be translated to JSON: \n\
\ \n\
\↳ " <> txt <> " "
where
txt = Core.pretty e
\" <> insert e

show (InvalidInlineContents record alternativeContents) =
Data.Text.unpack $
_ERROR <> ": Union value is not compatible with ❰Inline❱ nesting. \n\
\ \n\
\Explanation: You can use the ❰Inline❱ nesting to compactly encode a union while \n\
\preserving the name of the alternative. However the alternative must either be \n\
\empty or contain a record value. \n\
\ \n\
\For example: \n\
\ \n\
\ \n\
\ ┌─────────────────────────────────────────────────┐ \n\
\ │ let Example = < Empty | Record : { x : Bool } > │ \n\
\ │ │ \n\
\ │ let Nesting = < Inline | Nested : Text > │ \n\
\ │ │ \n\
\ │ in { field = \"name\" │ \n\
\ │ , nesting = Nesting.Inline │ \n\
\ │ , contents = Example.Empty │ An empty alternative \n\
\ │ } │ is ok. \n\
\ └─────────────────────────────────────────────────┘ \n\
\ \n\
\ \n\
\... is converted to this JSON: \n\
\ \n\
\ \n\
\ ┌─────────────────────┐ \n\
\ │ { \"name\": \"Empty\" } │ \n\
\ └─────────────────────┘ \n\
\ \n\
\ \n\
\ ┌──────────────────────────────────────────────┐ \n\
\ │ ... │ \n\
\ │ │ \n\
\ │ in { field = \"name\" │ \n\
\ │ , nesting = Nesting.Inline │ \n\
\ │ , contents = Example.Record { x = True } │ An alternative containing \n\
\ │ } │ a record value is ok. \n\
\ └──────────────────────────────────────────────┘ \n\
\ \n\
\ \n\
\... is converted to this JSON: \n\
\ \n\
\ \n\
\ ┌─────────────────────────────────┐ \n\
\ │ { \"name\": \"Record\", \"x\": true } │ \n\
\ └─────────────────────────────────┘ \n\
\ \n\
\ \n\
\This isn't valid: \n\
\ \n\
\ \n\
\ ┌──────────────────────────────────────────┐ \n\
\ │ let Example = < Foo : Bool > │ \n\
\ │ │ \n\
\ │ let Nesting = < Inline | Nested : Text > │ \n\
\ │ │ \n\
\ │ in { field = \"name\" │ \n\
\ │ , nesting = Nesting.Inline │ \n\
\ │ , contents = Example.Foo True │ ❰True❱ is not a record \n\
\ │ } │ \n\
\ └──────────────────────────────────────────┘ \n\
\ \n\
\ \n\
\The following Dhall expression could not be translated to JSON: \n\
\ \n\
\" <> insert record <> " \n\
\ \n\
\... because \n\
\ \n\
\" <> insert alternativeContents <> " \n\
\ \n\
\... is not a record."

_ERROR :: Data.Text.Text
_ERROR = "\ESC[1;31mError\ESC[0m"
_ERROR = Dhall.Util._ERROR

insert :: Pretty a => a -> Text
insert =
Pretty.renderStrict . Pretty.layoutPretty Dhall.Pretty.layoutOpts . Dhall.Util.insert

instance Exception CompileError

Expand Down Expand Up @@ -371,33 +453,18 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
, nesting
)
] | isInlineNesting nesting
, Just (alternativeName, Just (Core.RecordLit kvs)) <- getContents contents -> do
let kvs' =
Dhall.Map.insert
field
(Core.TextLit
(Core.Chunks
[]
alternativeName
)
)
kvs

loop (Core.RecordLit kvs')

| isInlineNesting nesting
, Just (alternativeName, Nothing) <- getContents contents -> do
let kvs =
Dhall.Map.singleton
field
(Core.TextLit
(Core.Chunks
[]
alternativeName
)
)
, Just (alternativeName, mExpr) <- getContents contents -> do
kvs0 <- case mExpr of
Just (Core.RecordLit kvs) -> return kvs
Just alternativeContents ->
Left (InvalidInlineContents e alternativeContents)
Nothing -> return mempty

let name = Core.TextLit (Core.Chunks [] alternativeName)

let kvs1 = Dhall.Map.insert field name kvs0

loop (Core.RecordLit kvs)
loop (Core.RecordLit kvs1)

_ -> do
a' <- traverse loop a
Expand Down
4 changes: 2 additions & 2 deletions dhall/dhall.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -537,7 +537,8 @@ Library
Dhall.Pretty,
Dhall.Repl,
Dhall.Tutorial,
Dhall.TypeCheck
Dhall.TypeCheck,
Dhall.Util
if !flag(cross)
Exposed-Modules:
Dhall.TH
Expand All @@ -546,7 +547,6 @@ Library
Dhall.Parser.Combinators,
Dhall.Import.Types,
Dhall.Eval,
Dhall.Util,
Paths_dhall
if flag(with-http)
Other-Modules:
Expand Down

0 comments on commit 93711ae

Please sign in to comment.