{-# 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

    -- * 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.Text.Prettyprint.Doc (Pretty)
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 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.List
import qualified Data.Map
import qualified Data.Ord
import qualified Data.Text
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 Lens.Family                           as Lens
import qualified Options.Applicative
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 (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text
_ERROR Text -> Text -> Text
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 (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
special Text -> Text -> Text
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 (Double -> String
forall a. Show a => a -> String
show Double
n)

    show (Unsupported Expr Void Void
e) =
        Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text
_ERROR Text -> Text -> Text
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\
            \" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr Void Void -> Text
forall a. Pretty a => a -> Text
insert Expr Void Void
e

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

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

insert :: Pretty a => a -> Text
insert :: a -> Text
insert = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.renderStrict (SimpleDocStream Ann -> Text)
-> (a -> SimpleDocStream Ann) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout (Doc Ann -> SimpleDocStream Ann)
-> (a -> Doc Ann) -> a -> SimpleDocStream Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Ann
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 :: Expr s Void -> Either CompileError Value
dhallToJSON Expr s Void
e0 = Expr Void Void -> Either CompileError Value
loop (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
Core.alphaNormalize (Expr s Void -> Expr Void Void
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr s Void
e0))
  where
    loop :: Expr Void Void -> Either CompileError Value
loop Expr Void Void
e = case Expr Void Void
e of
        Core.BoolLit Bool
a -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
a)
        Core.NaturalLit Natural
a -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
a)
        Core.IntegerLit Integer
a -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON Integer
a)
        Core.DoubleLit (DhallDouble Double
a) -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value
forall a. ToJSON a => a -> Value
toJSON Double
a)
        Core.TextLit (Core.Chunks [] Text
a) -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
a)
        Core.ListLit Maybe (Expr Void Void)
_ Seq (Expr Void Void)
a -> do
            Seq Value
a' <- (Expr Void Void -> Either CompileError Value)
-> Seq (Expr Void Void) -> Either CompileError (Seq Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Void Void -> Either CompileError Value
loop Seq (Expr Void Void)
a
            Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Value -> Value
forall a. ToJSON a => a -> Value
toJSON Seq Value
a')
        Core.Some Expr Void Void
a -> do
            Value
a' <- Expr Void Void -> Either CompileError Value
loop Expr Void Void
a
            Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
a')
        Core.App Expr Void Void
Core.None Expr Void Void
_ -> Value -> Either CompileError Value
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 Void Void
Core.None -> CompileError -> Either CompileError Value
forall a b. a -> Either a b
Left CompileError
BareNone
        Core.RecordLit Map Text (RecordField Void Void)
a ->
            case Map Text (RecordField Void Void) -> [(Text, RecordField Void Void)]
forall k v. Ord k => Map k v -> [(k, v)]
toOrderedList Map Text (RecordField Void Void)
a of
                [   (   "contents"
                    ,   Core.recordFieldValue -> contents
                    )
                 ,  (   "field"
                    ,   Core.recordFieldValue -> Core.TextLit
                            (Core.Chunks [] field)
                    )
                 ,  (   "nesting"
                    ,   Core.recordFieldValue -> Core.App
                            (Core.Field
                                (Core.Union
                                    [ ("Inline", mInlineType)
                                    , ("Nested", Just Core.Text)
                                    ]
                                )
                                (FA "Nested")
                            )
                            (Core.TextLit
                                (Core.Chunks [] nestedField)
                            )
                    )
                 ] | (Expr Void Void -> Bool) -> Maybe (Expr Void Void) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Expr Void Void -> Expr Void Void -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text (RecordField Void Void) -> Expr Void Void
forall s a. Map Text (RecordField s a) -> Expr s a
Core.Record []) Maybe (Expr Void Void)
mInlineType
                   , Just (Text
alternativeName, Maybe (Expr Void Void)
mExpr) <- Expr Void Void -> Maybe (Text, Maybe (Expr Void Void))
forall s. Expr s Void -> Maybe (Text, Maybe (Expr s Void))
getContents Expr Void Void
contents -> do
                       Value
contents' <- case Maybe (Expr Void Void)
mExpr of
                           Just Expr Void Void
expr -> Expr Void Void -> Either CompileError Value
loop Expr Void Void
expr
                           Maybe (Expr Void Void)
Nothing   -> Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null

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

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

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

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

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

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

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

                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Aeson.Array ([Value] -> 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
                                [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))
                                , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do
                                Value
mapValue <- Expr s a -> Either CompileError Value
outer Expr s a
mapExpression

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

                        [(Text, Value)]
ys <- (Expr s a -> Either CompileError (Text, Value))
-> [Expr s a] -> Either CompileError [(Text, Value)]
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 (Seq (Expr s a) -> [Expr s a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Aeson.Object ([(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text, Value)]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"number")) (Core.DoubleLit (DhallDouble Double
n))) =
                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value
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))) =
                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
text)
                    outer Expr s a
_ = CompileError -> Either CompileError Value
forall a b. a -> Either a b
Left (Expr Void Void -> CompileError
Unsupported Expr Void Void
e)

                Expr Void Void -> Either CompileError Value
forall s a. Expr s a -> Either CompileError Value
outer Expr Void Void
value
        Core.Lam Maybe CharacterSet
_ (FunctionBinding Void Void -> Expr Void Void
forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation -> Core.Const Const
Core.Type)
            (Core.Lam Maybe CharacterSet
_ (FunctionBinding Void Void -> Expr Void Void
forall s a. FunctionBinding s a -> Expr s a
Core.functionBindingAnnotation ->
                (Core.Record
                    [ ("array" , Core.recordFieldValue -> Core.Pi _ _ (Core.App Core.List (V 0)) (V 1))
                    , ("bool"  , Core.recordFieldValue -> Core.Pi _ _ Core.Bool (V 1))
                    , ("double", Core.recordFieldValue -> Core.Pi _ _ Core.Double (V 1))
                    , ("integer", Core.recordFieldValue -> Core.Pi _ _ Core.Integer (V 1))
                    , ("null"  , Core.recordFieldValue -> V 0)
                    , ("object", Core.recordFieldValue ->
                        Core.Pi _ _ (Core.App Core.List (Core.Record
                        [ ("mapKey", Core.recordFieldValue -> Core.Text)
                        , ("mapValue", Core.recordFieldValue -> V 0)
                        ])) (V 1))
                    , ("string", Core.recordFieldValue -> Core.Pi _ _ Core.Text (V 1))
                    ]
                ))
                Expr Void Void
value
            ) -> do
                let outer :: Expr s a -> Either CompileError Value
outer (Core.Field (V Int
0) (FA Text
"null")) =
                        Value -> Either CompileError Value
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)) =
                        Value -> Either CompileError Value
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 <- (Expr s a -> Either CompileError Value)
-> [Expr s a] -> Either CompileError [Value]
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 (Seq (Expr s a) -> [Expr s a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Aeson.Array ([Value] -> 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
                                    [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))
                                    , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do
                                Value
mapValue <- Expr s a -> Either CompileError Value
outer Expr s a
mapExpression

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

                        [(Text, Value)]
ys <- (Expr s a -> Either CompileError (Text, Value))
-> [Expr s a] -> Either CompileError [(Text, Value)]
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 (Seq (Expr s a) -> [Expr s a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr s a)
xs)

                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Aeson.Object ([(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text, Value)]
ys))
                    outer (Core.App (Core.Field (V Int
0) (FA Text
"double")) (Core.DoubleLit (DhallDouble Double
n))) =
                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value
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)) =
                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
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))) =
                        Value -> Either CompileError Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
text)
                    outer Expr s a
_ = CompileError -> Either CompileError Value
forall a b. a -> Either a b
Left (Expr Void Void -> CompileError
Unsupported Expr Void Void
e)

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

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

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

toOrderedList :: Ord k => Map k v -> [(k, v)]
toOrderedList :: Map k v -> [(k, v)]
toOrderedList =
        ((k, v) -> (k, v) -> Ordering) -> [(k, v)] -> [(k, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
Data.List.sortBy (((k, v) -> k) -> (k, v) -> (k, v) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Data.Ord.comparing (k, v) -> k
forall a b. (a, b) -> a
fst)
    ([(k, v)] -> [(k, v)])
-> (Map k v -> [(k, v)]) -> Map k v -> [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   Map k v -> [(k, v)]
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
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) ((Value -> Value) -> Object -> Object
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 ((Value -> Value) -> Array -> 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 Object -> Bool
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
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) ((Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
omitEmpty Object
object)
omitEmpty (Array Array
array) =
    if Array -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
elems then Value
Null else Array -> Value
Array Array
elems
  where
    elems :: Array
elems = (Value -> Bool) -> Array -> Array
forall a. (a -> Bool) -> Vector a -> Vector a
Vector.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) ((Value -> Value) -> Array -> Array
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 =
        (Value -> Value)
-> Mod FlagFields (Value -> Value) -> Parser (Value -> Value)
forall a. a -> Mod FlagFields a -> Parser a
Options.Applicative.flag'
            Value -> Value
omitEmpty
            (   String -> Mod FlagFields (Value -> Value)
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"omit-empty"
            Mod FlagFields (Value -> Value)
-> Mod FlagFields (Value -> Value)
-> Mod FlagFields (Value -> Value)
forall a. Semigroup a => a -> a -> a
<>  String -> Mod FlagFields (Value -> Value)
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 =
        (Value -> Value)
-> (Value -> Value)
-> Mod FlagFields (Value -> Value)
-> Parser (Value -> Value)
forall a. a -> a -> Mod FlagFields a -> Parser a
Options.Applicative.flag
            Value -> Value
omitNull
            Value -> Value
forall a. a -> a
id
            (   String -> Mod FlagFields (Value -> Value)
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"preserve-null"
            Mod FlagFields (Value -> Value)
-> Mod FlagFields (Value -> Value)
-> Mod FlagFields (Value -> Value)
forall a. Semigroup a => a -> a -> a
<>  String -> Mod FlagFields (Value -> Value)
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 Parser (Value -> Value)
-> Parser (Value -> Value) -> Parser (Value -> Value)
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 :: Text -> Text -> Conversion
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 :: Conversion -> Expr s Void -> Expr s Void
convertToHomogeneousMaps Conversion
NoConversion Expr s Void
e0 = Expr s Void
e0
convertToHomogeneousMaps (Conversion {Text
mapValue :: Text
mapKey :: Text
mapValue :: Conversion -> Text
mapKey :: Conversion -> Text
..}) Expr s Void
e0 = Expr s Void -> Expr s Void
forall s. Expr s Void -> Expr s Void
loop (Expr s Void -> Expr s Void
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr s Void
e0)
  where
    loop :: Expr s Void -> Expr s Void
loop Expr s Void
e = case Expr s Void
e of
        Core.Const Const
a ->
            Const -> Expr s Void
forall s a. Const -> Expr s a
Core.Const Const
a

        Core.Var Var
v ->
            Var -> Expr s Void
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 Void
a Expr s Void
b ->
            Maybe CharacterSet
-> FunctionBinding s Void -> Expr s Void -> Expr s Void
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
Core.Lam Maybe CharacterSet
cs FunctionBinding s Void
a Expr s Void
b

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

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

        Core.Let (Binding Maybe s
src0 Text
a Maybe s
src1 Maybe (Maybe s, Expr s Void)
b Maybe s
src2 Expr s Void
c) Expr s Void
d ->
            Binding s Void -> Expr s Void -> Expr s Void
forall s a. Binding s a -> Expr s a -> Expr s a
Core.Let (Maybe s
-> Text
-> Maybe s
-> Maybe (Maybe s, Expr s Void)
-> Maybe s
-> Expr s Void
-> Binding s Void
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 Void)
b' Maybe s
src2 Expr s Void
c') Expr s Void
d'
          where
            b' :: Maybe (Maybe s, Expr s Void)
b' = ((Maybe s, Expr s Void) -> (Maybe s, Expr s Void))
-> Maybe (Maybe s, Expr s Void) -> Maybe (Maybe s, Expr s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Expr s Void -> Expr s Void)
-> (Maybe s, Expr s Void) -> (Maybe s, Expr s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr s Void -> Expr s Void
loop) Maybe (Maybe s, Expr s Void)
b
            c' :: Expr s Void
c' =            Expr s Void -> Expr s Void
loop  Expr s Void
c
            d' :: Expr s Void
d' =            Expr s Void -> Expr s Void
loop  Expr s Void
d

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        Core.Record Map Text (RecordField s Void)
a ->
            Map Text (RecordField s Void) -> Expr s Void
forall s a. Map Text (RecordField s a) -> Expr s a
Core.Record Map Text (RecordField s Void)
a'
          where
            a' :: Map Text (RecordField s Void)
a' = ASetter
  (RecordField s Void)
  (RecordField s Void)
  (Expr s Void)
  (Expr s Void)
-> (Expr s Void -> Expr s Void)
-> RecordField s Void
-> RecordField s Void
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over ASetter
  (RecordField s Void)
  (RecordField s Void)
  (Expr s Void)
  (Expr s Void)
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 Void -> Expr s Void
loop (RecordField s Void -> RecordField s Void)
-> Map Text (RecordField s Void) -> Map Text (RecordField s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s Void)
a

        Core.RecordLit Map Text (RecordField s Void)
a ->
            Map Text (RecordField s Void) -> Expr s Void
forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit Map Text (RecordField s Void)
a'
          where
            a' :: Map Text (RecordField s Void)
a' = ASetter
  (RecordField s Void)
  (RecordField s Void)
  (Expr s Void)
  (Expr s Void)
-> (Expr s Void -> Expr s Void)
-> RecordField s Void
-> RecordField s Void
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over ASetter
  (RecordField s Void)
  (RecordField s Void)
  (Expr s Void)
  (Expr s Void)
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 Void -> Expr s Void
loop (RecordField s Void -> RecordField s Void)
-> Map Text (RecordField s Void) -> Map Text (RecordField s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s Void)
a

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

        Core.Combine Maybe CharacterSet
cs Maybe Text
a Expr s Void
b Expr s Void
c ->
            Maybe CharacterSet
-> Maybe Text -> Expr s Void -> Expr s Void -> Expr s Void
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 Void
b' Expr s Void
c'
          where
            b' :: Expr s Void
b' = Expr s Void -> Expr s Void
loop Expr s Void
b
            c' :: Expr s Void
c' = Expr s Void -> Expr s Void
loop Expr s Void
c

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

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

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

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

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

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

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

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

        Core.Equivalent Expr s Void
a Expr s Void
b ->
            Expr s Void -> Expr s Void -> Expr s Void
forall s a. Expr s a -> Expr s a -> Expr s a
Core.Equivalent Expr s Void
a' Expr s Void
b'
          where
            a' :: Expr s Void
a' = Expr s Void -> Expr s Void
loop Expr s Void
a
            b' :: Expr s Void
b' = Expr s Void -> Expr s Void
loop Expr s Void
b

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

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

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

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

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

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

    noConversion :: Parser Conversion
noConversion =
        Conversion -> Mod FlagFields Conversion -> Parser Conversion
forall a. a -> Mod FlagFields a -> Parser a
Options.Applicative.flag'
            Conversion
NoConversion
            (   String -> Mod FlagFields Conversion
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.Applicative.long String
"no-maps"
            Mod FlagFields Conversion
-> Mod FlagFields Conversion -> Mod FlagFields Conversion
forall a. Semigroup a => a -> a -> a
<>  String -> Mod FlagFields Conversion
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 :: SpecialDoubleMode
-> Expr s Void -> Either CompileError (Expr s Void)
handleSpecialDoubles SpecialDoubleMode
specialDoubleMode =
    LensLike
  (WrappedMonad (Either CompileError))
  (Expr s Void)
  (Expr s Void)
  (Expr s Void)
  (Expr s Void)
-> (Expr s Void -> Either CompileError (Maybe (Expr s Void)))
-> Expr s Void
-> Either CompileError (Expr s Void)
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
Dhall.Optics.rewriteMOf LensLike
  (WrappedMonad (Either CompileError))
  (Expr s Void)
  (Expr s Void)
  (Expr s Void)
  (Expr s Void)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Core.subExpressions Expr s Void -> Either CompileError (Maybe (Expr s Void))
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       -> Expr s a -> Either CompileError (Maybe (Expr s a))
forall (m :: * -> *) s a s a.
Monad m =>
Expr s a -> m (Maybe (Expr s a))
useYAMLEncoding
            SpecialDoubleMode
ForbidWithinJSON      -> Expr s a -> Either CompileError (Maybe (Expr s a))
forall s a a. Expr s a -> Either CompileError (Maybe a)
forbidWithinJSON
            SpecialDoubleMode
ApproximateWithinJSON -> Expr s a -> Either CompileError (Maybe (Expr s a))
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))
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
n =
            Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
Core.TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"inf")))
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 =
            Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
Core.TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"-inf")))
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
n =
            Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
Core.TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
"nan")))
    useYAMLEncoding Expr s a
_ =
        Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Expr s a)
forall a. Maybe a
Nothing

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

    approximateWithinJSON :: Expr s a -> m (Maybe (Expr s a))
approximateWithinJSON (Core.DoubleLit (DhallDouble Double
n))
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 =
            Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (DhallDouble -> Expr s a
forall s a. DhallDouble -> Expr s a
Core.DoubleLit (Double -> DhallDouble
DhallDouble Double
1.7976931348623157e308)))
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n Bool -> Bool -> Bool
&& Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 =
            Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (DhallDouble -> Expr s a
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
_ =
        Maybe (Expr s a) -> m (Maybe (Expr s a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Expr s a)
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
    Expr Src Import
parsedExpression <- Either ParseError (Expr Src Import) -> IO (Expr Src Import)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"(input)" Maybe String
mFilePath) Text
code)

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

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

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

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

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

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