{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

{-| This library only exports a single `dhallToJSON` function for translating a
    Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@
    library

    NOTE: The @yaml@ library uses the same `Value` type to represent YAML
    files, so you can use this to convert Dhall expressions to YAML, too

    See the @dhall@ package if you would like to transform Dhall source code
    into a Dhall syntax tree.  Similarly, see the @aeson@ package if you would
    like to translate a JSON syntax tree into JSON.

    This package also provides @dhall-to-json@ and @dhall-to-yaml@ executables
    which you can use to compile Dhall source code directly to JSON or YAML for
    your convenience

    Not all Dhall expressions can be converted to JSON since JSON is not a
    programming language.  The only things you can convert are:

    * @Bool@s
    * @Natural@s
    * @Integer@s
    * @Double@s
    * @Text@ values
    * @List@s
    * @Optional@ values
    * unions
    * records

    Dhall @Bool@s translate to JSON bools:

> $ dhall-to-json <<< 'True'
> true
> $ dhall-to-json <<< 'False'
> false

    Dhall numbers translate to JSON numbers:

> $ dhall-to-json <<< '+2'
> 2
> $ dhall-to-json <<< '2'
> 2
> $ dhall-to-json <<< '2.3'
> 2.3

    Dhall @Text@ translates to JSON text:

> $ dhall-to-json <<< '"ABC"'
> "ABC"

    Dhall @List@s translate to JSON lists:

> $ dhall-to-json <<< '[1, 2, 3] : List Natural'
> [
>   1,
>   2,
>   3
> ]

    Dhall @Optional@ values translate to @null@ if absent and the unwrapped
    value otherwise:

> $ dhall-to-json <<< 'None Natural'
> null
> $ dhall-to-json <<< 'Some 1'
> 1

    Dhall records translate to JSON records:

> $ dhall-to-json <<< '{ foo = 1, bar = True }'
> {
>   "bar": true,
>   "foo": 1
> }

    Dhall unions translate to the wrapped value:

> $ dhall-to-json <<< "< Left : Natural | Right : Natural>.Left 2"
> 2
> $ cat config
> let MyType =
>       < Person : { age : Natural, name : Text } | Place : { location : Text } >
>
> in  [ MyType.Person { age = 47, name = "John" }
>     , MyType.Place { location = "North Pole" }
>     , MyType.Place { location = "Sahara Desert" }
>     , MyType.Person { age = 35, name = "Alice" }
>     ]
> $ dhall-to-json <<< "./config"
> [
>   {
>     "age": 47,
>     "name": "John"
>   },
>   {
>     "location": "North Pole"
>   },
>   {
>     "location": "Sahara Desert"
>   },
>   {
>     "age": 35,
>     "name": "Alice"
>   }
> ]

    You can preserve the name of the alternative if you wrap the value in a
    record with three fields:

    * @contents@: The union literal that you want to preserve the tag of

    * @field@: the name of the field that will store the name of the
      alternative

    * @nesting@: A value of type @\< Inline | Nested : Text \>@.

    If @nesting@ is set to @Inline@ and the union literal stored in @contents@
    contains a record then the name of the alternative is stored inline within
    the same record.  For example, this code:

> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
>
> let Nesting = < Inline | Nested : Text >
>
> in  { field    = "name"
>     , nesting  = Nesting.Inline
>     , contents = Example.Left { foo = 2 }
>     }

    ... produces this JSON:

> {
>   "foo": 2,
>   "name": "Left"
> }

    If @nesting@ is set to @Nested nestedField@ then the union is stored
    underneath a field named @nestedField@.  For example, this code:

> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
>
> let Nesting = < Inline | Nested : Text >
>
> in  { field    = "name"
>     , nesting  = Nesting.Nested "value"
>     , contents = Example.Left { foo = 2 }
>     }

    ... produces this JSON:

> {
>   "name": "Left",
>   "value": {
>     "foo": 2
>   }
> }

    You can also translate Dhall expressions encoding weakly-typed JSON
    (see: <https://prelude.dhall-lang.org/JSON/Type>):

> $ cat ./example.dhall
> let JSON = https://prelude.dhall-lang.org/JSON/package.dhall
>
> in  JSON.object
>     [ { mapKey = "foo", mapValue = JSON.null }
>     , { mapKey =
>           "bar"
>       , mapValue =
>           JSON.array [ JSON.number 1.0, JSON.bool True ]
>       }
>     ]

    By default, the fields that are evaluated to @null@ will be removed,
    but here we're preserving them with the @--preserveNull@ flag.

> $ dhall-to-json --preserveNull <<< './example.dhall'
> {
>   "bar": [
>     1,
>     true
>   ],
>   "foo": null
> }

    Also, all Dhall expressions are normalized before translation to JSON:

> $ dhall-to-json <<< "True == False"
> false

-}

module Dhall.JSON (
    -- * Dhall to JSON
      dhallToJSON
    , omitNull
    , omitEmpty
    , parsePreservationAndOmission
    , Conversion(..)
    , defaultConversion
    , convertToHomogeneousMaps
    , parseConversion
    , SpecialDoubleMode(..)
    , handleSpecialDoubles
    , codeToValue
    , codeToHeaderAndValue

    -- * Exceptions
    , CompileError(..)
    ) where

import Control.Applicative (empty, (<|>))
import Control.Exception   (Exception, throwIO)
import Control.Monad       (guard)
import Data.Aeson          (ToJSON (..), Value (..))
import Data.Maybe          (fromMaybe)
import Data.Text           (Text)
import Data.Void           (Void)
import Dhall.Core          (Binding (..), DhallDouble (..), Expr)
import Dhall.Import        (SemanticCacheMode (..))
import Dhall.JSON.Util     (pattern FA, pattern V)
import Dhall.Map           (Map)
import Dhall.Parser        (Header(..))
import Options.Applicative (Parser)
import Prelude             hiding (getContents)
import Prettyprinter       (Pretty)

import qualified Data.Aeson                as Aeson
import qualified Data.Foldable             as Foldable
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 Dhall.Import
import qualified Dhall.JSON.Compat         as JSON.Compat
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 Lens.Family               as Lens
import qualified Options.Applicative
import qualified Prettyprinter.Render.Text as Pretty
import qualified System.FilePath

{-| This is the exception type for errors that might arise when translating
    Dhall to JSON

    Because the majority of Dhall language features do not translate to JSON
    this just returns the expression that failed
-}
data CompileError
    = Unsupported (Expr Void Void)
    | SpecialDouble Double
    | BareNone
    | InvalidInlineContents (Expr Void Void) (Expr Void Void)

instance Show CompileError where
    show :: CompileError -> String
show CompileError
BareNone =
       Text -> String
Data.Text.unpack forall a b. (a -> b) -> a -> b
$
            Text
_ERROR forall a. Semigroup a => a -> a -> a
<> Text
": ❰None❱ is not valid on its own                                      \n\
            \                                                                                \n\
            \Explanation: The conversion to JSON/YAML does not accept ❰None❱ in isolation as \n\
            \a valid way to represent ❰null❱.  In Dhall, ❰None❱ is a function whose input is \n\
            \a type and whose output is an ❰Optional❱ of that type.                          \n\
            \                                                                                \n\
            \For example:                                                                    \n\
            \                                                                                \n\
            \                                                                                \n\
            \    ┌─────────────────────────────────┐  ❰None❱ is a function whose result is   \n\
            \    │ None : ∀(a : Type) → Optional a │  an ❰Optional❱ value, but the function  \n\
            \    └─────────────────────────────────┘  itself is not a valid ❰Optional❱ value \n\
            \                                                                                \n\
            \                                                                                \n\
            \    ┌─────────────────────────────────┐  ❰None Natural❱ is a valid ❰Optional❱   \n\
            \    │ None Natural : Optional Natural │  value (an absent ❰Natural❱ number in   \n\
            \    └─────────────────────────────────┘  this case)                             \n\
            \                                                                                \n\
            \                                                                                \n\
            \                                                                                \n\
            \The conversion to JSON/YAML only translates the fully applied form to ❰null❱.   "

    show (SpecialDouble Double
n) =
       Text -> String
Data.Text.unpack forall a b. (a -> b) -> a -> b
$
            Text
_ERROR forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
special forall a. Semigroup a => a -> a -> a
<> Text
" 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\
            \                                                                                \n\
            \● Using ❰dhall-to-yaml❱ instead of ❰dhall-to-json❱, since YAML does support     \n\
            \  ❰NaN❱/❰Infinity❱/❰-Infinity❱                                                  \n\
            \                                                                                \n\
            \● Enabling the ❰--approximate-special-doubles❱ flag which will encode ❰NaN❱ as  \n\
            \  ❰null❱, ❰Infinity❱ as the maximum ❰Double❱, and ❰-Infinity❱ as the minimum    \n\
            \❰Double❱                                                                        \n\
            \                                                                                \n\
            \● See if there is a way to remove ❰NaN❱/❰Infinity❱/❰-Infinity❱ from the         \n\
            \  expression that you are converting to JSON                                    "
      where
        special :: Text
special = String -> Text
Data.Text.pack (forall a. Show a => a -> String
show Double
n)

    show (Unsupported Expr X X
e) =
        Text -> String
Data.Text.unpack forall a b. (a -> b) -> a -> b
$
            Text
_ERROR forall a. Semigroup a => a -> a -> a
<> Text
": Cannot translate to JSON                                            \n\
            \                                                                                \n\
            \Explanation: Only primitive values, records, unions, ❰List❱s, and ❰Optional❱    \n\
            \values can be translated from Dhall to JSON                                     \n\
            \                                                                                \n\
            \The following Dhall expression could not be translated to JSON:                 \n\
            \                                                                                \n\
            \" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
insert Expr X X
e

    show (InvalidInlineContents Expr X X
record Expr X X
alternativeContents) =
        Text -> String
Data.Text.unpack forall a b. (a -> b) -> a -> b
$
            Text
_ERROR forall a. Semigroup a => a -> a -> a
<> Text
": 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\
            \" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
insert Expr X X
record forall a. Semigroup a => a -> a -> a
<> Text
"                                                         \n\
            \                                                                                \n\
            \... because                                                                     \n\
            \                                                                                \n\
            \" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
insert Expr X X
alternativeContents forall a. Semigroup a => a -> a -> a
<> Text
"                                            \n\
            \                                                                                \n\
            \... is not a record."

_ERROR :: Data.Text.Text
_ERROR :: Text
_ERROR = forall string. IsString string => string
Dhall.Util._ERROR

insert :: Pretty a => a -> Text
insert :: forall a. Pretty a => a -> Text
insert = forall ann. SimpleDocStream ann -> Text
Pretty.renderStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert

instance Exception CompileError

{-| Convert a Dhall expression to the equivalent JSON expression

>>> :set -XOverloadedStrings
>>> :set -XOverloadedLists
>>> import Core
>>> dhallToJSON (RecordLit [("foo", IntegerLit 1), ("bar", TextLit "ABC")])
Right (Object (fromList [("foo",Number 1.0),("bar",String "ABC")]))
>>> fmap Aeson.encode it
Right "{\"foo\":1,\"bar\":\"ABC\"}"
-}
dhallToJSON
    :: Expr s Void
    -> Either CompileError Value
dhallToJSON :: forall s. Expr s X -> Either CompileError Value
dhallToJSON Expr s X
e0 = Expr X X -> Either CompileError Value
loop (forall s a. Expr s a -> Expr s a
Core.alphaNormalize (forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr s X
e0))
  where
    loop :: Expr X X -> Either CompileError Value
loop Expr X X
e = case Expr X X
e of
        Core.BoolLit Bool
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Bool
a)
        Core.NaturalLit Natural
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Natural
a)
        Core.IntegerLit Integer
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Integer
a)
        Core.DoubleLit (DhallDouble Double
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Double
a)
        Core.TextLit (Core.Chunks [] Text
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Text
a)
        Core.ListLit Maybe (Expr X X)
_ Seq (Expr X X)
a -> do
            Seq Value
a' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr X X -> Either CompileError Value
loop Seq (Expr X X)
a
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Seq Value
a')
        Core.Some Expr X X
a -> do
            Value
a' <- Expr X X -> Either CompileError Value
loop Expr X X
a
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Value
a')
        Core.App Expr X X
Core.None Expr X X
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null
        -- Provide a nicer error message for a common user mistake.
        --
        -- See: https://github.com/dhall-lang/dhall-lang/issues/492
        Expr X X
Core.None -> forall a b. a -> Either a b
Left CompileError
BareNone
        Expr X X
_ | Just Text
text <- forall a s. Pretty a => Expr s a -> Maybe Text
Dhall.Pretty.temporalToText Expr X X
e ->
            Expr X X -> Either CompileError Value
loop (forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
text))
        Core.RecordLit Map Text (RecordField X X)
a ->
            case forall k v. Ord k => Map k v -> [(k, v)]
toOrderedList Map Text (RecordField X X)
a of
                [   (   Text
"contents"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr X X
contents
                    )
                 ,  (   Text
"field"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.TextLit
                            (Core.Chunks [] Text
field)
                    )
                 ,  (   Text
"nesting"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.App
                            (Core.Field
                                (Core.Union
                                    [ (Text
"Inline", Maybe (Expr X X)
mInlineType)
                                    , (Text
"Nested", Just Expr X X
Core.Text)
                                    ]
                                )
                                (FA Text
"Nested")
                            )
                            (Core.TextLit
                                (Core.Chunks [] Text
nestedField)
                            )
                    )
                 ] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== forall s a. Map Text (RecordField s a) -> Expr s a
Core.Record []) Maybe (Expr X X)
mInlineType
                   , Just (Text
alternativeName, Maybe (Expr X X)
mExpr) <- forall s. Expr s X -> Maybe (Text, Maybe (Expr s X))
getContents Expr X X
contents -> do
                       Value
contents' <- case Maybe (Expr X X)
mExpr of
                           Just Expr X X
expr -> Expr X X -> Either CompileError Value
loop Expr X X
expr
                           Maybe (Expr X X)
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null

                       let taggedValue :: Map Text Value
taggedValue =
                               forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList
                                   [   (   Text
field
                                       ,   forall a. ToJSON a => a -> Value
toJSON Text
alternativeName
                                       )
                                   ,   (   Text
nestedField
                                       ,   Value
contents'
                                       )
                                   ]

                       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON Map Text Value
taggedValue)

                [   (   Text
"contents"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr X X
contents
                    )
                 ,  (   Text
"field"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.TextLit
                            (Core.Chunks [] Text
field)
                    )
                 ,  (   Text
"nesting"
                    ,   forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr X X
nesting
                    )
                 ] | forall s. Expr s X -> Bool
isInlineNesting Expr X X
nesting
                   , Just (Text
alternativeName, Maybe (Expr X X)
mExpr) <- forall s. Expr s X -> Maybe (Text, Maybe (Expr s X))
getContents Expr X X
contents -> do
                       Map Text (RecordField X X)
kvs0 <- case Maybe (Expr X X)
mExpr of
                           Just (Core.RecordLit Map Text (RecordField X X)
kvs) -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Text (RecordField X X)
kvs
                           Just Expr X X
alternativeContents ->
                               forall a b. a -> Either a b
Left (Expr X X -> Expr X X -> CompileError
InvalidInlineContents Expr X X
e Expr X X
alternativeContents)
                           Maybe (Expr X X)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

                       let name :: RecordField s a
name = forall s a. Expr s a -> RecordField s a
Core.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
alternativeName)

                       let kvs1 :: Map Text (RecordField X X)
kvs1 = forall k v. Ord k => k -> v -> Map k v -> Map k v
Dhall.Map.insert Text
field forall {s} {a}. RecordField s a
name Map Text (RecordField X X)
kvs0

                       Expr X X -> Either CompileError Value
loop (forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit Map Text (RecordField X X)
kvs1)

                [(Text, RecordField X X)]
_ -> do
                    Map Text Value
a' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Expr X X -> Either CompileError Value
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. RecordField s a -> Expr s a
Core.recordFieldValue) Map Text (RecordField X X)
a
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON (forall k v. Map k v -> Map k v
Dhall.Map.toMap Map Text Value
a'))
        Core.App (Core.Field (Core.Union Map Text (Maybe (Expr X X))
_) FieldSelection X
_) Expr X X
b -> Expr X X -> Either CompileError Value
loop Expr X X
b
        Core.Field (Core.Union Map Text (Maybe (Expr X X))
_) (FA Text
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON Text
k)
        Core.Lam Maybe CharacterSet
_ (forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation -> Core.Const Const
Core.Type)
            (Core.Lam Maybe CharacterSet
_ (forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation ->
                (Core.Record
                    [ (Text
"array" , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ (Core.App Expr X X
Core.List (V Int
0)) (V Int
1))
                    , (Text
"bool"  , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Bool (V Int
1))
                    , (Text
"null"  , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> V Int
0)
                    , (Text
"number", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Double (V Int
1))
                    , (Text
"object", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue ->
                        Core.Pi Maybe CharacterSet
_ Text
_ (Core.App Expr X X
Core.List (Core.Record
                        [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr X X
Core.Text)
                        , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> V Int
0)])) (V Int
1))
                    , (Text
"string", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Text (V Int
1))
                    ]
                ))
                Expr X X
value
            ) -> do
                let outer :: Expr s a -> Either CompileError Value
outer (Core.Field (V Int
0) (FA Text
"null")) = forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"bool")) (Core.BoolLit Bool
b)) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Aeson.Bool Bool
b)
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"array")) (Core.ListLit Maybe (Expr s a)
_ Seq (Expr s a)
xs)) = do
                        [Value]
ys <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> Either CompileError Value
outer (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Aeson.Array (forall a. [a] -> Vector a
Vector.fromList [Value]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"object")) (Core.ListLit Maybe (Expr s a)
_ Seq (Expr s a)
xs)) = do
                        let inner :: Expr s a -> Either CompileError (Text, Value)
inner (Core.RecordLit
                                [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.TextLit (Core.Chunks [] Text
mapKey))
                                , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
mapExpression)]) = do
                                Value
mapValue <- Expr s a -> Either CompileError Value
outer Expr s a
mapExpression

                                forall (m :: * -> *) a. Monad m => a -> m a
return (Text
mapKey, Value
mapValue)
                            inner Expr s a
_ = forall a b. a -> Either a b
Left (Expr X X -> CompileError
Unsupported Expr X X
e)

                        [(Text, Value)]
ys <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> Either CompileError (Text, Value)
inner (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Aeson.Object ([(Text, Value)] -> Object
JSON.Compat.objectFromList [(Text, Value)]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"number")) (Core.DoubleLit (DhallDouble Double
n))) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON Double
n)
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"string")) (Core.TextLit (Core.Chunks [] Text
text))) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Text
text)
                    outer Expr s a
_ = forall a b. a -> Either a b
Left (Expr X X -> CompileError
Unsupported Expr X X
e)

                forall {s} {a}. Expr s a -> Either CompileError Value
outer Expr X X
value
        Core.Lam Maybe CharacterSet
_ (forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation -> Core.Const Const
Core.Type)
            (Core.Lam Maybe CharacterSet
_ (forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation ->
                (Core.Record
                    [ (Text
"array" , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ (Core.App Expr X X
Core.List (V Int
0)) (V Int
1))
                    , (Text
"bool"  , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Bool (V Int
1))
                    , (Text
"double", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Double (V Int
1))
                    , (Text
"integer", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Integer (V Int
1))
                    , (Text
"null"  , forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> V Int
0)
                    , (Text
"object", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue ->
                        Core.Pi Maybe CharacterSet
_ Text
_ (Core.App Expr X X
Core.List (Core.Record
                        [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr X X
Core.Text)
                        , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> V Int
0)
                        ])) (V Int
1))
                    , (Text
"string", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.Pi Maybe CharacterSet
_ Text
_ Expr X X
Core.Text (V Int
1))
                    ]
                ))
                Expr X X
value
            ) -> do
                let outer :: Expr s a -> Either CompileError Value
outer (Core.Field (V Int
0) (FA Text
"null")) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"bool")) (Core.BoolLit Bool
b)) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Aeson.Bool Bool
b)
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"array")) (Core.ListLit Maybe (Expr s a)
_ Seq (Expr s a)
xs)) = do
                        [Value]
ys <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> Either CompileError Value
outer (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Aeson.Array (forall a. [a] -> Vector a
Vector.fromList [Value]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"object")) (Core.ListLit Maybe (Expr s a)
_ Seq (Expr s a)
xs)) = do
                        let inner :: Expr s a -> Either CompileError (Text, Value)
inner (Core.RecordLit
                                    [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Core.TextLit (Core.Chunks [] Text
mapKey))
                                    , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
mapExpression)]) = do
                                Value
mapValue <- Expr s a -> Either CompileError Value
outer Expr s a
mapExpression

                                forall (m :: * -> *) a. Monad m => a -> m a
return (Text
mapKey, Value
mapValue)
                            inner Expr s a
_ = forall a b. a -> Either a b
Left (Expr X X -> CompileError
Unsupported Expr X X
e)

                        [(Text, Value)]
ys <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> Either CompileError (Text, Value)
inner (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Aeson.Object ([(Text, Value)] -> Object
JSON.Compat.objectFromList [(Text, Value)]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"double")) (Core.DoubleLit (DhallDouble Double
n))) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON Double
n)
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"integer")) (Core.IntegerLit Integer
n)) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Aeson.toJSON Integer
n)
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"string")) (Core.TextLit (Core.Chunks [] Text
text))) =
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON Text
text)
                    outer Expr s a
_ = forall a b. a -> Either a b
Left (Expr X X -> CompileError
Unsupported Expr X X
e)

                forall {s} {a}. Expr s a -> Either CompileError Value
outer Expr X X
value
        Expr X X
_ -> forall a b. a -> Either a b
Left (Expr X X -> CompileError
Unsupported Expr X X
e)

getContents :: Expr s Void -> Maybe (Text, Maybe (Expr s Void))
getContents :: forall s. Expr s X -> Maybe (Text, Maybe (Expr s X))
getContents (Core.App
                (Core.Field
                    Expr s X
_
                    (FA Text
alternativeName)
                )
                Expr s X
expression
            ) = forall a. a -> Maybe a
Just (Text
alternativeName, forall a. a -> Maybe a
Just Expr s X
expression)
getContents (Core.Field Expr s X
_ (FA Text
alternativeName)) = forall a. a -> Maybe a
Just (Text
alternativeName, forall a. Maybe a
Nothing)
getContents Expr s X
_ = forall a. Maybe a
Nothing

isInlineNesting :: Expr s Void -> Bool
isInlineNesting :: forall s. Expr s X -> Bool
isInlineNesting (Core.App
                    (Core.Field
                        (Core.Union
                            [ (Text
"Inline", Just (Core.Record []))
                            , (Text
"Nested", Just Expr s X
Core.Text)
                            ]
                        )
                        (FA Text
"Inline")
                    )
                    (Core.RecordLit [])
                )  = Bool
True
isInlineNesting (Core.Field
                    (Core.Union
                        [ (Text
"Inline", Maybe (Expr s X)
Nothing)
                        , (Text
"Nested", Just Expr s X
Core.Text)
                        ]
                    )
                    (FA Text
"Inline")
                ) = Bool
True
isInlineNesting Expr s X
_ = Bool
False

toOrderedList :: Ord k => Map k v -> [(k, v)]
toOrderedList :: forall k v. Ord k => Map k v -> [(k, v)]
toOrderedList =
        forall a. (a -> a -> Ordering) -> [a] -> [a]
Data.List.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Data.Ord.comparing forall a b. (a, b) -> a
fst)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall k v. Ord k => Map k v -> [(k, v)]
Dhall.Map.toList

-- | Omit record fields that are @null@
omitNull :: Value -> Value
omitNull :: Value -> Value
omitNull (Object Object
object) = Object -> Value
Object Object
fields
  where
    fields :: Object
fields = (Value -> Bool) -> Object -> Object
JSON.Compat.filterObject (forall a. Eq a => a -> a -> Bool
/= Value
Null) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
omitNull Object
object)
omitNull (Array Array
array) =
    Array -> Value
Array (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
omitNull Array
array)
omitNull (String Text
string) =
    Text -> Value
String Text
string
omitNull (Number Scientific
number) =
    Scientific -> Value
Number Scientific
number
omitNull (Bool Bool
bool) =
    Bool -> Value
Bool Bool
bool
omitNull Value
Null =
    Value
Null

{-| Omit record fields that are @null@, arrays and records whose transitive
    fields are all null
-}
omitEmpty :: Value -> Value
omitEmpty :: Value -> Value
omitEmpty (Object Object
object) =
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Object
fields then Value
Null else Object -> Value
Object Object
fields
  where
    fields :: Object
fields = (Value -> Bool) -> Object -> Object
JSON.Compat.filterObject (forall a. Eq a => a -> a -> Bool
/= Value
Null) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
omitEmpty Object
object)
omitEmpty (Array Array
array) =
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
elems then Value
Null else Array -> Value
Array Array
elems
  where
    elems :: Array
elems = forall a. (a -> Bool) -> Vector a -> Vector a
Vector.filter (forall a. Eq a => a -> a -> Bool
/= Value
Null) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
omitEmpty Array
array)
omitEmpty (String Text
string) =
    Text -> Value
String Text
string
omitEmpty (Number Scientific
number) =
    Scientific -> Value
Number Scientific
number
omitEmpty (Bool Bool
bool) =
    Bool -> Value
Bool Bool
bool
omitEmpty Value
Null =
    Value
Null

-- | Parser for command-line options related to omitting fields
parseOmission :: Parser (Value -> Value)
parseOmission :: Parser (Value -> Value)
parseOmission =
        forall a. a -> Mod FlagFields a -> Parser a
Options.Applicative.flag'
            Value -> Value
omitEmpty
            (   forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"omit-empty"
            forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
Options.Applicative.help String
"Omit record fields that are null or empty records"
            )

-- | Parser for command-line options related to preserving null fields.
parseNullPreservation :: Parser (Value -> Value)
parseNullPreservation :: Parser (Value -> Value)
parseNullPreservation =
        forall a. a -> a -> Mod FlagFields a -> Parser a
Options.Applicative.flag
            Value -> Value
omitNull
            forall a. a -> a
id
            (   forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"preserve-null"
            forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
Options.Applicative.help String
"Preserve record fields that are null"
            )

-- | Combines parsers for command-line options related to preserving & omitting null fields.
parsePreservationAndOmission :: Parser (Value -> Value)
parsePreservationAndOmission :: Parser (Value -> Value)
parsePreservationAndOmission = Parser (Value -> Value)
parseOmission forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Value -> Value)
parseNullPreservation

{-| Specify whether or not to convert association lists of type
    @List { mapKey: Text, mapValue : v }@ to records
-}
data Conversion
    = NoConversion
    | Conversion { Conversion -> Text
mapKey :: Text, Conversion -> Text
mapValue :: Text }

defaultConversion :: Conversion
defaultConversion :: Conversion
defaultConversion = Conversion
    { mapKey :: Text
mapKey = Text
"mapKey"
    , mapValue :: Text
mapValue = Text
"mapValue"
    }

{-| Convert association lists to homogeneous maps

    This converts an association list of the form:

    > [ { mapKey = k0, mapValue = v0 }, { mapKey = k1, mapValue = v1 } ]

    ... to a record of the form:

    > { k0 = v0, k1 = v1 }
-}
convertToHomogeneousMaps :: Conversion -> Expr s Void -> Expr s Void
convertToHomogeneousMaps :: forall s. Conversion -> Expr s X -> Expr s X
convertToHomogeneousMaps Conversion
NoConversion Expr s X
e0 = Expr s X
e0
convertToHomogeneousMaps (Conversion {Text
mapValue :: Text
mapKey :: Text
mapValue :: Conversion -> Text
mapKey :: Conversion -> Text
..}) Expr s X
e0 = forall {s}. Expr s X -> Expr s X
loop (forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr s X
e0)
  where
    loop :: Expr s X -> Expr s X
loop Expr s X
e = case Expr s X
e of
        Core.Const Const
a ->
            forall s a. Const -> Expr s a
Core.Const Const
a

        Core.Var Var
v ->
            forall s a. Var -> Expr s a
Core.Var Var
v

        {- Minor hack: Don't descend into lambda, since the only thing it can
           possibly encode is a Boehm-Berarducci-encoded JSON value.  In such a
           case we do *not* want to perform this rewrite since it will
           interfere with decoding the value.
        -}
        Core.Lam Maybe CharacterSet
cs FunctionBinding s X
a Expr s X
b ->
            forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
Core.Lam Maybe CharacterSet
cs FunctionBinding s X
a Expr s X
b

        Core.Pi Maybe CharacterSet
cs Text
a Expr s X
b Expr s X
c ->
            forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
Core.Pi Maybe CharacterSet
cs Text
a Expr s X
b' Expr s X
c'
          where
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b
            c' :: Expr s X
c' = Expr s X -> Expr s X
loop Expr s X
c

        Core.App Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.App Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.Let (Binding Maybe s
src0 Text
a Maybe s
src1 Maybe (Maybe s, Expr s X)
b Maybe s
src2 Expr s X
c) Expr s X
d ->
            forall s a. Binding s a -> Expr s a -> Expr s a
Core.Let (forall s a.
Maybe s
-> Text
-> Maybe s
-> Maybe (Maybe s, Expr s a)
-> Maybe s
-> Expr s a
-> Binding s a
Binding Maybe s
src0 Text
a Maybe s
src1 Maybe (Maybe s, Expr s X)
b' Maybe s
src2 Expr s X
c') Expr s X
d'
          where
            b' :: Maybe (Maybe s, Expr s X)
b' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop) Maybe (Maybe s, Expr s X)
b
            c' :: Expr s X
c' =            Expr s X -> Expr s X
loop  Expr s X
c
            d' :: Expr s X
d' =            Expr s X -> Expr s X
loop  Expr s X
d

        Core.Annot Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.Annot Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Expr s X
Core.Bool ->
            forall s a. Expr s a
Core.Bool

        Core.BoolLit Bool
a ->
            forall s a. Bool -> Expr s a
Core.BoolLit Bool
a

        Core.BoolAnd Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.BoolAnd Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.BoolOr Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.BoolOr Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.BoolEQ Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.BoolEQ Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.BoolNE Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.BoolNE Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.BoolIf Expr s X
a Expr s X
b Expr s X
c ->
            forall s a. Expr s a -> Expr s a -> Expr s a -> Expr s a
Core.BoolIf Expr s X
a' Expr s X
b' Expr s X
c'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b
            c' :: Expr s X
c' = Expr s X -> Expr s X
loop Expr s X
c

        Expr s X
Core.Natural ->
            forall s a. Expr s a
Core.Natural

        Core.NaturalLit Natural
a ->
            forall s a. Natural -> Expr s a
Core.NaturalLit Natural
a

        Expr s X
Core.NaturalFold ->
            forall s a. Expr s a
Core.NaturalFold

        Expr s X
Core.NaturalBuild ->
            forall s a. Expr s a
Core.NaturalBuild

        Expr s X
Core.NaturalIsZero ->
            forall s a. Expr s a
Core.NaturalIsZero

        Expr s X
Core.NaturalEven ->
            forall s a. Expr s a
Core.NaturalEven

        Expr s X
Core.NaturalOdd ->
            forall s a. Expr s a
Core.NaturalOdd

        Expr s X
Core.NaturalToInteger ->
            forall s a. Expr s a
Core.NaturalToInteger

        Expr s X
Core.NaturalShow ->
            forall s a. Expr s a
Core.NaturalShow

        Expr s X
Core.NaturalSubtract ->
            forall s a. Expr s a
Core.NaturalSubtract

        Core.NaturalPlus Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.NaturalPlus Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.NaturalTimes Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.NaturalTimes Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Expr s X
Core.Integer ->
            forall s a. Expr s a
Core.Integer

        Core.IntegerLit Integer
a ->
            forall s a. Integer -> Expr s a
Core.IntegerLit Integer
a

        Expr s X
Core.IntegerClamp ->
            forall s a. Expr s a
Core.IntegerClamp

        Expr s X
Core.IntegerNegate ->
            forall s a. Expr s a
Core.IntegerNegate

        Expr s X
Core.IntegerShow ->
            forall s a. Expr s a
Core.IntegerShow

        Expr s X
Core.IntegerToDouble ->
            forall s a. Expr s a
Core.IntegerToDouble

        Expr s X
Core.Double ->
            forall s a. Expr s a
Core.Double

        Core.DoubleLit DhallDouble
a ->
            forall s a. DhallDouble -> Expr s a
Core.DoubleLit DhallDouble
a

        Expr s X
Core.DoubleShow ->
            forall s a. Expr s a
Core.DoubleShow

        Expr s X
Core.Text ->
            forall s a. Expr s a
Core.Text

        Core.TextLit (Core.Chunks [(Text, Expr s X)]
a Text
b) ->
            forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [(Text, Expr s X)]
a' Text
b)
          where
            a' :: [(Text, Expr s X)]
a' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop) [(Text, Expr s X)]
a

        Core.TextAppend Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.TextAppend Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Expr s X
Core.TextReplace ->
            forall s a. Expr s a
Core.TextReplace

        Expr s X
Core.TextShow ->
            forall s a. Expr s a
Core.TextShow

        Expr s X
Core.Date ->
            forall s a. Expr s a
Core.Date

        Core.DateLiteral Day
d ->
            forall s a. Day -> Expr s a
Core.DateLiteral Day
d

        Expr s X
Core.Time ->
            forall s a. Expr s a
Core.Time

        Core.TimeLiteral TimeOfDay
t Word
p ->
            forall s a. TimeOfDay -> Word -> Expr s a
Core.TimeLiteral TimeOfDay
t Word
p

        Expr s X
Core.TimeZone ->
            forall s a. Expr s a
Core.TimeZone

        Core.TimeZoneLiteral TimeZone
z ->
            forall s a. TimeZone -> Expr s a
Core.TimeZoneLiteral TimeZone
z

        Expr s X
Core.List ->
            forall s a. Expr s a
Core.List

        Core.ListLit Maybe (Expr s X)
a Seq (Expr s X)
b ->
            case Maybe (Expr s X)
transform of
                Just Expr s X
c  -> Expr s X -> Expr s X
loop Expr s X
c
                Maybe (Expr s X)
Nothing -> forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit Maybe (Expr s X)
a' Seq (Expr s X)
b'
          where
            elements :: [Expr s X]
elements = forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s X)
b

            toKeyValue :: Expr s Void -> Maybe (Text, Expr s Void)
            toKeyValue :: forall s. Expr s X -> Maybe (Text, Expr s X)
toKeyValue (Core.RecordLit Map Text (RecordField s X)
m) = do
                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => t a -> Int
Foldable.length Map Text (RecordField s X)
m forall a. Eq a => a -> a -> Bool
== Int
2)

                Expr s X
key   <- forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
mapKey   Map Text (RecordField s X)
m
                Expr s X
value <- forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
mapValue Map Text (RecordField s X)
m

                Text
keyText <- case Expr s X
key of
                    Core.TextLit (Core.Chunks [] Text
keyText) ->
                        forall (m :: * -> *) a. Monad m => a -> m a
return Text
keyText

                    Core.Field (Core.Union Map Text (Maybe (Expr s X))
_) (FA Text
keyText) ->
                        forall (m :: * -> *) a. Monad m => a -> m a
return Text
keyText

                    Expr s X
_ ->
                        forall (f :: * -> *) a. Alternative f => f a
empty

                forall (m :: * -> *) a. Monad m => a -> m a
return (Text
keyText, Expr s X
value)
            toKeyValue Expr s X
_ =
                forall (f :: * -> *) a. Alternative f => f a
empty

            transform :: Maybe (Expr s X)
transform =
                case [Expr s X]
elements of
                    [] ->
                        case Maybe (Expr s X)
a of
                            Just (Core.App Expr s X
Core.List (Core.Record Map Text (RecordField s X)
m)) -> do
                                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => t a -> Int
Foldable.length Map Text (RecordField s X)
m forall a. Eq a => a -> a -> Bool
== Int
2)
                                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k v. Ord k => k -> Map k v -> Bool
Dhall.Map.member Text
mapKey   Map Text (RecordField s X)
m)
                                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k v. Ord k => k -> Map k v -> Bool
Dhall.Map.member Text
mapValue Map Text (RecordField s X)
m)
                                forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit forall a. Monoid a => a
mempty)
                            Maybe (Expr s X)
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

                    [Expr s X]
_  -> do
                        [(Text, Expr s X)]
keyValues <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall s. Expr s X -> Maybe (Text, Expr s X)
toKeyValue [Expr s X]
elements

                        let recordLiteral :: Map Text (RecordField s X)
recordLiteral = forall s a. Expr s a -> RecordField s a
Core.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList [(Text, Expr s X)]
keyValues

                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit Map Text (RecordField s X)
recordLiteral)

            a' :: Maybe (Expr s X)
a' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop Maybe (Expr s X)
a
            b' :: Seq (Expr s X)
b' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop Seq (Expr s X)
b

        Core.ListAppend Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.ListAppend Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Expr s X
Core.ListBuild ->
            forall s a. Expr s a
Core.ListBuild

        Expr s X
Core.ListFold ->
            forall s a. Expr s a
Core.ListFold

        Expr s X
Core.ListLength ->
            forall s a. Expr s a
Core.ListLength

        Expr s X
Core.ListHead ->
            forall s a. Expr s a
Core.ListHead

        Expr s X
Core.ListLast ->
            forall s a. Expr s a
Core.ListLast

        Expr s X
Core.ListIndexed ->
            forall s a. Expr s a
Core.ListIndexed

        Expr s X
Core.ListReverse ->
            forall s a. Expr s a
Core.ListReverse

        Expr s X
Core.Optional ->
            forall s a. Expr s a
Core.Optional

        Core.Some Expr s X
a ->
            forall s a. Expr s a -> Expr s a
Core.Some Expr s X
a'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a

        Expr s X
Core.None ->
            forall s a. Expr s a
Core.None

        Core.Record Map Text (RecordField s X)
a ->
            forall s a. Map Text (RecordField s a) -> Expr s a
Core.Record Map Text (RecordField s X)
a'
          where
            a' :: Map Text (RecordField s X)
a' = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
Core.recordFieldExprs Expr s X -> Expr s X
loop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s X)
a

        Core.RecordLit Map Text (RecordField s X)
a ->
            forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit Map Text (RecordField s X)
a'
          where
            a' :: Map Text (RecordField s X)
a' = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
Core.recordFieldExprs Expr s X -> Expr s X
loop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s X)
a

        Core.Union Map Text (Maybe (Expr s X))
a ->
            forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
Core.Union Map Text (Maybe (Expr s X))
a'
          where
            a' :: Map Text (Maybe (Expr s X))
a' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop) Map Text (Maybe (Expr s X))
a

        Core.Combine Maybe CharacterSet
cs Maybe Text
a Expr s X
b Expr s X
c ->
            forall s a.
Maybe CharacterSet
-> Maybe Text -> Expr s a -> Expr s a -> Expr s a
Core.Combine Maybe CharacterSet
cs Maybe Text
a Expr s X
b' Expr s X
c'
          where
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b
            c' :: Expr s X
c' = Expr s X -> Expr s X
loop Expr s X
c

        Core.CombineTypes Maybe CharacterSet
cs Expr s X
a Expr s X
b ->
            forall s a. Maybe CharacterSet -> Expr s a -> Expr s a -> Expr s a
Core.CombineTypes Maybe CharacterSet
cs Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.Prefer Maybe CharacterSet
cs PreferAnnotation s X
a Expr s X
b Expr s X
c ->
            forall s a.
Maybe CharacterSet
-> PreferAnnotation s a -> Expr s a -> Expr s a -> Expr s a
Core.Prefer Maybe CharacterSet
cs PreferAnnotation s X
a Expr s X
b' Expr s X
c'
          where
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b
            c' :: Expr s X
c' = Expr s X -> Expr s X
loop Expr s X
c

        Core.RecordCompletion Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.RecordCompletion Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.Merge Expr s X
a Expr s X
b Maybe (Expr s X)
c ->
            forall s a. Expr s a -> Expr s a -> Maybe (Expr s a) -> Expr s a
Core.Merge Expr s X
a' Expr s X
b' Maybe (Expr s X)
c'
          where
            a' :: Expr s X
a' =      Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' =      Expr s X -> Expr s X
loop Expr s X
b
            c' :: Maybe (Expr s X)
c' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop Maybe (Expr s X)
c

        Core.ToMap Expr s X
a Maybe (Expr s X)
b ->
            forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
Core.ToMap Expr s X
a' Maybe (Expr s X)
b'
          where
            a' :: Expr s X
a' =      Expr s X -> Expr s X
loop Expr s X
a
            b' :: Maybe (Expr s X)
b' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s X -> Expr s X
loop Maybe (Expr s X)
b

        Core.ShowConstructor Expr s X
a ->
            forall s a. Expr s a -> Expr s a
Core.ShowConstructor Expr s X
a'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a

        Core.Field Expr s X
a FieldSelection s
b ->
            forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr s X
a' FieldSelection s
b
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a

        Core.Project Expr s X
a Either [Text] (Expr s X)
b ->
            forall s a. Expr s a -> Either [Text] (Expr s a) -> Expr s a
Core.Project Expr s X
a' Either [Text] (Expr s X)
b
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a

        Core.Assert Expr s X
a ->
            forall s a. Expr s a -> Expr s a
Core.Assert Expr s X
a'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a

        Core.Equivalent Maybe CharacterSet
cs Expr s X
a Expr s X
b ->
            forall s a. Maybe CharacterSet -> Expr s a -> Expr s a -> Expr s a
Core.Equivalent Maybe CharacterSet
cs Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.With Expr s X
a NonEmpty WithComponent
b Expr s X
c ->
            forall s a.
Expr s a -> NonEmpty WithComponent -> Expr s a -> Expr s a
Core.With Expr s X
a' NonEmpty WithComponent
b Expr s X
c'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            c' :: Expr s X
c' = Expr s X -> Expr s X
loop Expr s X
c

        Core.ImportAlt Expr s X
a Expr s X
b ->
            forall s a. Expr s a -> Expr s a -> Expr s a
Core.ImportAlt Expr s X
a' Expr s X
b'
          where
            a' :: Expr s X
a' = Expr s X -> Expr s X
loop Expr s X
a
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.Note s
a Expr s X
b ->
            forall s a. s -> Expr s a -> Expr s a
Core.Note s
a Expr s X
b'
          where
            b' :: Expr s X
b' = Expr s X -> Expr s X
loop Expr s X
b

        Core.Embed X
a ->
            forall s a. a -> Expr s a
Core.Embed X
a

-- | Parser for command-line options related to homogeneous map support
parseConversion :: Parser Conversion
parseConversion :: Parser Conversion
parseConversion =
        Parser Conversion
conversion
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Conversion
noConversion
  where
    conversion :: Parser Conversion
conversion = Text -> Text -> Conversion
Conversion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
parseKeyField forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
parseValueField
      where
        parseKeyField :: Parser Text
parseKeyField =
            forall s. IsString s => Mod OptionFields s -> Parser s
Options.Applicative.strOption
                (   forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"key"
                forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
Options.Applicative.help String
"Reserved key field name for association lists"
                forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. HasValue f => a -> Mod f a
Options.Applicative.value Text
"mapKey"
                forall a. Semigroup a => a -> a -> a
<>  forall a (f :: * -> *). (a -> String) -> Mod f a
Options.Applicative.showDefaultWith Text -> String
Data.Text.unpack
                )

        parseValueField :: Parser Text
parseValueField =
            forall s. IsString s => Mod OptionFields s -> Parser s
Options.Applicative.strOption
                (   forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"value"
                forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
Options.Applicative.help String
"Reserved value field name for association lists"
                forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. HasValue f => a -> Mod f a
Options.Applicative.value Text
"mapValue"
                forall a. Semigroup a => a -> a -> a
<>  forall a (f :: * -> *). (a -> String) -> Mod f a
Options.Applicative.showDefaultWith Text -> String
Data.Text.unpack
                )

    noConversion :: Parser Conversion
noConversion =
        forall a. a -> Mod FlagFields a -> Parser a
Options.Applicative.flag'
            Conversion
NoConversion
            (   forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"no-maps"
            forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
Options.Applicative.help String
"Disable conversion of association lists to homogeneous maps"
            )

-- | This option specifies how to encode @NaN@\/@Infinity@\/@-Infinity@
data SpecialDoubleMode
    = UseYAMLEncoding
    -- ^ YAML natively supports @NaN@\/@Infinity@\/@-Infinity@
    | ForbidWithinJSON
    -- ^ Forbid @NaN@\/@Infinity@\/@-Infinity@ because JSON doesn't support them
    | ApproximateWithinJSON
    -- ^ Encode @NaN@\/@Infinity@\/@-Infinity@ as
    --   @null@\/@1.7976931348623157e308@\/@-1.7976931348623157e308@,
    --   respectively

{-| Pre-process an expression containing @NaN@\/@Infinity@\/@-Infinity@,
    handling them as specified according to the `SpecialDoubleMode`
-}
handleSpecialDoubles
    :: SpecialDoubleMode -> Expr s Void -> Either CompileError (Expr s Void)
handleSpecialDoubles :: forall s.
SpecialDoubleMode -> Expr s X -> Either CompileError (Expr s X)
handleSpecialDoubles SpecialDoubleMode
specialDoubleMode =
    forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
Dhall.Optics.rewriteMOf forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Core.subExpressions forall {s} {a} {s} {a}.
Expr s a -> Either CompileError (Maybe (Expr s a))
rewrite
  where
    rewrite :: Expr s a -> Either CompileError (Maybe (Expr s a))
rewrite =
        case SpecialDoubleMode
specialDoubleMode of
            SpecialDoubleMode
UseYAMLEncoding       -> forall {m :: * -> *} {s} {a} {s} {a}.
Monad m =>
Expr s a -> m (Maybe (Expr s a))
useYAMLEncoding
            SpecialDoubleMode
ForbidWithinJSON      -> forall {s} {a} {a}. Expr s a -> Either CompileError (Maybe a)
forbidWithinJSON
            SpecialDoubleMode
ApproximateWithinJSON -> forall {m :: * -> *} {s} {a} {s} {a}.
Monad m =>
Expr s a -> m (Maybe (Expr s a))
approximateWithinJSON

    useYAMLEncoding :: Expr s a -> m (Maybe (Expr s a))
useYAMLEncoding (Core.DoubleLit (DhallDouble Double
n))
        | forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
0 forall a. Ord a => a -> a -> Bool
< Double
n =
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"inf")))
        | forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n forall a. Ord a => a -> a -> Bool
< Double
0 =
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"-inf")))
        | forall a. RealFloat a => a -> Bool
isNaN Double
n =
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall s a. Chunks s a -> Expr s a
Core.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"nan")))
    useYAMLEncoding Expr s a
_ =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    forbidWithinJSON :: Expr s a -> Either CompileError (Maybe a)
forbidWithinJSON (Core.DoubleLit (DhallDouble Double
n))
        | forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isNaN Double
n =
            forall a b. a -> Either a b
Left (Double -> CompileError
SpecialDouble Double
n)
    forbidWithinJSON Expr s a
_ =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    approximateWithinJSON :: Expr s a -> m (Maybe (Expr s a))
approximateWithinJSON (Core.DoubleLit (DhallDouble Double
n))
        | forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n forall a. Ord a => a -> a -> Bool
> Double
0 =
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall s a. DhallDouble -> Expr s a
Core.DoubleLit (Double -> DhallDouble
DhallDouble Double
1.7976931348623157e308)))
        | forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n forall a. Ord a => a -> a -> Bool
< Double
0 =
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall s a. DhallDouble -> Expr s a
Core.DoubleLit (Double -> DhallDouble
DhallDouble (-Double
1.7976931348623157e308))))
        -- Do nothing for @NaN@, which already encodes to @null@
    approximateWithinJSON Expr s a
_ =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

{-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value

>>> :set -XOverloadedStrings
>>> import Core
>>> Dhall.JSON.codeToValue defaultConversion ForbidWithinJSON Nothing "{ a = 1 }"
>>> Object (fromList [("a",Number 1.0)])
-}
codeToValue
  :: Conversion
  -> SpecialDoubleMode
  -> Maybe FilePath  -- ^ The source file path. If no path is given, imports
                     -- are resolved relative to the current directory.
  -> Text  -- ^ Input text.
  -> IO Value
codeToValue :: Conversion -> SpecialDoubleMode -> Maybe String -> Text -> IO Value
codeToValue Conversion
conversion SpecialDoubleMode
specialDoubleMode Maybe String
mFilePath Text
code = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (Conversion
-> SpecialDoubleMode -> Maybe String -> Text -> IO (Header, Value)
codeToHeaderAndValue Conversion
conversion SpecialDoubleMode
specialDoubleMode Maybe String
mFilePath Text
code)

{-| This is like `codeToValue`, except also returning a `Header` that is a
    valid YAML comment derived from the original Dhall code's `Header`
-}
codeToHeaderAndValue
  :: Conversion
  -> SpecialDoubleMode
  -> Maybe FilePath  -- ^ The source file path. If no path is given, imports
                     -- are resolved relative to the current directory.
  -> Text  -- ^ Input text.
  -> IO (Header, Value)
codeToHeaderAndValue :: Conversion
-> SpecialDoubleMode -> Maybe String -> Text -> IO (Header, Value)
codeToHeaderAndValue Conversion
conversion SpecialDoubleMode
specialDoubleMode Maybe String
mFilePath Text
code = do
    (Header Text
header, Expr Src Import
parsedExpression) <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (String -> Text -> Either ParseError (Header, Expr Src Import)
Dhall.Parser.exprAndHeaderFromText (forall a. a -> Maybe a -> a
fromMaybe String
"(input)" Maybe String
mFilePath) Text
code)

    let adapt :: Text -> Text
adapt Text
line =
            case Text -> Text -> Maybe Text
Data.Text.stripPrefix Text
"--" Text
line of
                Just Text
suffix -> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
suffix
                Maybe Text
Nothing     -> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
line

    let yamlHeader :: Text
yamlHeader = [Text] -> Text
Data.Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
adapt (Text -> [Text]
Data.Text.lines Text
header))

    let rootDirectory :: String
rootDirectory = case Maybe String
mFilePath of
            Maybe String
Nothing -> String
"."
            Just String
fp -> ShowS
System.FilePath.takeDirectory String
fp

    Expr Src X
resolvedExpression <- String -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src X)
Dhall.Import.loadRelativeTo String
rootDirectory SemanticCacheMode
UseSemanticCache Expr Src Import
parsedExpression

    Expr Src X
_ <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (forall s. Expr s X -> Either (TypeError s X) (Expr s X)
Dhall.TypeCheck.typeOf Expr Src X
resolvedExpression)

    let convertedExpression :: Expr Src X
convertedExpression =
            forall s. Conversion -> Expr s X -> Expr s X
convertToHomogeneousMaps Conversion
conversion Expr Src X
resolvedExpression

    Expr Src X
specialDoubleExpression <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (forall s.
SpecialDoubleMode -> Expr s X -> Either CompileError (Expr s X)
handleSpecialDoubles SpecialDoubleMode
specialDoubleMode Expr Src X
convertedExpression)

    case forall s. Expr s X -> Either CompileError Value
dhallToJSON Expr Src X
specialDoubleExpression of
      Left  CompileError
err  -> forall e a. Exception e => e -> IO a
Control.Exception.throwIO CompileError
err
      Right Value
json -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Header
Header Text
yamlHeader, Value
json)