{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

{-| Convert JSON data to Dhall in one of two ways:

    * By default, the conversion will make a best-effort at inferring the
      corresponding Dhall type

    * Optionally, you can specify an expected Dhall type necessary to make the
      translation unambiguous.

    Either way, if you supply the generated Dhall result to @dhall-to-json@ you
    should get back the original JSON.

    Only a subset of Dhall types are supported when converting from JSON:

    * @Bool@
    * @Natural@
    * @Integer@
    * @Double@
    * @Text@
    * @List@
    * @Optional@
    * unions
    * records
    * @Prelude.Type.Map@
    * @Prelude.Type.JSON@ - You can always convert JSON data to this type as a
      last resort if you don't know the schema in advance.

    You can use this code as a library (this module) or as an executable
    named @json-to-dhall@, which is used in the examples below.

    By default the @json-to-dhall@ executable attempts to infer the
    appropriate Dhall type from the JSON data, like this:

> $ json-to-dhall <<< 1
> 1

    ... but you can also provide an explicit schema on the command line if you
    prefer a slightly different Dhall type which still represents the same JSON
    value:

> $ json-to-dhall Integer <<< 1
> +1

    You can also get the best of both worlds by using the @type@ subcommand to
    infer the schema:

> $ json-to-dhall type <<< '[ "up", "down" ]' | tee schema.dhall
> List Text

    ... and then edit the @./schema.dhall@ file to better match the type you
    intended, such as:

> $ $EDITOR schema.dhall
> $ cat ./schema.dhall
> List < up | down >

    ... and then use the edited schema for subsequent conversions:

> $ json-to-dhall ./schema.dhall <<< '[ "up", "down" ]'
> [ < down | up >.up, < down | up >.down ]

== Primitive types

    JSON @Bool@s translate to Dhall bools:

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

    JSON numbers translate to Dhall numbers:

> $ json-to-dhall <<< 2
> 2
> $ json-to-dhall <<< -2
> -2
> $ json-to-dhall <<< -2.1
> -2.1
> $ json-to-dhall Natural <<< 2
> 2
> $ json-to-dhall Integer <<< 2
> +2
> $ json-to-dhall Double <<< 2
> 2.0

    JSON text corresponds to Dhall @Text@ by default:

> $ json-to-dhall <<< '"foo bar"'
> "foo bar"

    ... but you can also decode text into a more structured enum, too, if you
    provide an explicit schema:

> $ json-to-dhall '< A | B >' <<< '"A"'
> < A | B >.A

== Lists and records

    Dhall @List@s correspond to JSON lists:

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

    You can even decode an empty JSON list to Dhall:

> $ json-to-dhall <<< '[]'
> [] : List <>

    ... which will infer the empty @\<\>@ type if there are no other constraints
    on the type.  If you provide an explicit type annotation then the conversion
    will use that instead:

> $ json-to-dhall 'List Natural' <<< '[]'
> [] : List Natural

    Dhall records correspond to JSON records:

> $ json-to-dhall <<< '{ "foo": [ 1, 2, 3 ] }'
> { foo = [ 1, 2, 3 ] }

    If you specify a schema with additional @Optional@ fields then they will be
    @None@ if absent:

> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ] }'
> { bar = None Bool, foo = [ 1, 2, 3 ] }

    ... and @Some@ if present:

> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'
> { bar = Some True, foo = [ 1, 2, 3 ] }

    If you specify a schema with too few fields, then the behavior is
    configurable.  By default, the conversion will reject extra fields:

> $ json-to-dhall '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'
>
> Error: Key(s) bar present in the JSON object but not in the expected Dhall record type. This is not allowed unless you enable the --records-loose flag:
>
> Expected Dhall type:
> { foo : List Natural }
>
> JSON:
> {
>     "foo": [
>         1,
>         2,
>         3
>     ],
>     "bar": true
> }

  ... as the error message suggests, extra fields are ignored if you enable the
  @--records-loose@ flag.

> $ json-to-dhall --records-loose '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'
> { foo = [ 1, 2, 3 ] }

    You can convert JSON key-value arrays to Dhall records, but only if you
    supply an explicit Dhall type:

> $ json-to-dhall '{ a : Natural, b : Text }' <<< '[ { "key": "a", "value": 1 }, { "key": "b", "value": "asdf" } ]'
> { a = 1, b = "asdf" }

    You can also disable this behavior using the @--no-keyval-arrays@:

> $ json-to-dhall --no-keyval-arrays '{ a : Natural, b : Text }' <<< '[ { "key": "a", "value": 1 }, { "key": "b", "value": "asdf" } ]'
> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag:

    You can also convert JSON records to Dhall @Map@s, but only if you supply an
    explicit schema:

> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{ "foo": "bar" }'
> toMap { foo = "bar" }

    The map keys can even be union types instead of `Text`:

> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{ "A": 1, "B": 2 }'
> [ { mapKey = < A | B >.A, mapValue = 1 }, { mapKey = < A | B >.B, mapValue = 2 } ]

    You can similarly disable this feature using @--no-keyval-maps@:

> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{ "foo": "bar" }'
> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag

    If your schema is a record with a `List` field and omit that field in the JSON,
    you'll get an error:

> $ json-to-dhall  '{ a : List Natural }' <<< '{}'
>
>
> Error: Key a, expected by Dhall type:
> List Natural
> is not present in JSON object:
> {}

    You can use the @--omissible-lists@ option to default to an empty list in this case

> $ json-to-dhall --omissible-lists  '{ a : List Natural }' <<< '{}'
> { a = [] : List Natural }

== Optional values and unions

    JSON @null@ values correspond to @Optional@ Dhall values:

> $ json-to-dhall <<< 'null'
> None <>

    ... and the schema inference logic will automatically wrap other values in
    @Optional@ to ensure that the types line up:

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

    A field that might be absent also corresponds to an @Optional@ type:

> $ json-to-dhall <<< '[ { "x": 1 }, { "x": 2, "y": true } ]'
> [ { x = 1, y = None Bool }, { x = 2, y = Some True } ]

    For Dhall union types the correct value will be based on matching the type
    of JSON expression if you give an explicit type:

> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]'
> [ < Left : Text | Right : Integer >.Right +1
> , < Left : Text | Right : Integer >.Left "bar"
> ]

    Also, the schema inference logic will still infer a union anyway in order
    to reconcile simple types:

> $ json-to-dhall <<< '[ 1, true ]'
> [ < Bool : Bool | Natural : Natural >.Natural 1
> , < Bool : Bool | Natural : Natural >.Bool True
> ]

    In presence of multiple potential matches, the first will be selected by
    default:

> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" }

    This will result in error if @--unions-strict@ flag is used, with the list
    of alternative matches being reported (as a Dhall list)

> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
> Error: More than one union component type matches JSON value
> ...
> Possible matches:
> < Left : Text | Middle : Text | Right : Integer >.Left "bar"
> --------
> < Left : Text | Middle : Text | Right : Integer >.Middle "bar"

== Weakly-typed JSON

If you don't know the JSON's schema in advance, you can decode into the most
general schema possible:

> $ cat ./schema.dhall
> https://prelude.dhall-lang.org/JSON/Type

> $ json-to-dhall ./schema.dhall <<< '[ { "foo": null, "bar": [ 1.0, true ] } ]'
>   λ(JSON : Type)
> → λ(string : Text → JSON)
> → λ(number : Double → JSON)
> → λ(object : List { mapKey : Text, mapValue : JSON } → JSON)
> → λ(array : List JSON → JSON)
> → λ(bool : Bool → JSON)
> → λ(null : JSON)
> → array
>   [ object
>     ( toMap
>         { bar = array [ number 1.0, bool True ]
>         , foo = null
>         }
>     )
>   ]

You can also mix and match JSON fields whose schemas are known or unknown:

> $ cat ./mixed.dhall
> List
> { foo : Optional Natural
> , bar : https://prelude.dhall-lang.org/JSON/Type
> }

> $ json-to-dhall ./mixed.dhall <<< '[ { "foo": null, "bar": [ 1.0, true ] } ]'
> [ { bar =
>         λ(JSON : Type)
>       → λ(string : Text → JSON)
>       → λ(number : Double → JSON)
>       → λ(object : List { mapKey : Text, mapValue : JSON } → JSON)
>       → λ(array : List JSON → JSON)
>       → λ(bool : Bool → JSON)
>       → λ(null : JSON)
>       → array [ number 1.0, bool True ]
>   , foo =
>       None Natural
>   }
> ]

    The schema inference algorithm will also infer this schema of last resort
    when unifying a simple type with a record or a list:

> $ json-to-dhall <<< '[ 1, [] ]'
> [ λ(JSON : Type) →
>   λ ( json
>     : { array : List JSON → JSON
>       , bool : Bool → JSON
>       , double : Double → JSON
>       , integer : Integer → JSON
>       , null : JSON
>       , object : List { mapKey : Text, mapValue : JSON } → JSON
>       , string : Text → JSON
>       }
>     ) →
>     json.integer +1
> , λ(JSON : Type) →
>   λ ( json
>     : { array : List JSON → JSON
>       , bool : Bool → JSON
>       , double : Double → JSON
>       , integer : Integer → JSON
>       , null : JSON
>       , object : List { mapKey : Text, mapValue : JSON } → JSON
>       , string : Text → JSON
>       }
>     ) →
>     json.array ([] : List JSON)
> ]

-}

module Dhall.JSONToDhall (
    -- * JSON to Dhall
      parseConversion
    , Conversion(..)
    , defaultConversion
    , resolveSchemaExpr
    , typeCheckSchemaExpr
    , dhallFromJSON

    -- * Schema inference
    , Schema(..)
    , RecordSchema(..)
    , UnionSchema(..)
    , inferSchema
    , schemaToDhallType

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

import Control.Applicative      ((<|>))
import Control.Exception        (Exception, throwIO)
import Control.Monad.Catch      (MonadCatch, throwM)
import Data.Aeson               (Value)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Either              (rights)
import Data.Foldable            (toList)
import Data.List                ((\\))
import Data.Monoid              (Any (..))
import Data.Scientific          (floatingOrInteger, toRealFloat)
import Data.Text                (Text)
import Data.Void                (Void)
import Dhall.Core               (Chunks (..), DhallDouble (..), Expr (App))
import Dhall.JSON.Util          (pattern FA, pattern V)
import Dhall.Parser             (Src)
import Options.Applicative      (Parser)

import qualified Data.Aeson                 as Aeson
import qualified Data.Aeson.Types           as Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Foldable              as Foldable
import qualified Data.Map
import qualified Data.Map.Merge.Lazy        as Data.Map.Merge
import qualified Data.Sequence              as Seq
import qualified Data.String
import qualified Data.Text                  as Text
import qualified Data.Vector                as Vector
import qualified Dhall.Core                 as D
import qualified Dhall.Import
import qualified Dhall.JSON.Compat          as JSON.Compat
import qualified Dhall.Lint                 as Lint
import qualified Dhall.Map                  as Map
import qualified Dhall.Optics               as Optics
import qualified Dhall.Parser
import qualified Dhall.TypeCheck            as D
import qualified Options.Applicative        as O

-- ---------------
-- Command options
-- ---------------

-- | Standard parser for options related to the conversion method
parseConversion :: Parser Conversion
parseConversion :: Parser Conversion
parseConversion = Bool -> Bool -> Bool -> UnionConv -> Bool -> Conversion
Conversion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
parseStrict
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
parseKVArr
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
parseKVMap
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser UnionConv
parseUnion
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
parseOmissibleLists
  where
    parseStrict :: Parser Bool
parseStrict =
            forall a. a -> Mod FlagFields a -> Parser a
O.flag' Bool
True
            (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"records-strict"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Fail if any JSON fields are missing from the expected Dhall type"
            )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
O.flag' Bool
False
            (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"records-loose"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Tolerate JSON fields not present within the expected Dhall type"
            )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

    parseKVArr :: Parser Bool
parseKVArr  =  Mod FlagFields Bool -> Parser Bool
O.switch
                (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"no-keyval-arrays"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Disable conversion of key-value arrays to records"
                )
    parseKVMap :: Parser Bool
parseKVMap  =  Mod FlagFields Bool -> Parser Bool
O.switch
                (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"no-keyval-maps"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Disable conversion of homogeneous map objects to association lists"
                )
    parseOmissibleLists :: Parser Bool
parseOmissibleLists = Mod FlagFields Bool -> Parser Bool
O.switch
                          ( forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"omissible-lists"
                          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Tolerate missing list values, they are assumed empty"
                          )

-- | Parser for command options related to treating union types
parseUnion :: Parser UnionConv
parseUnion :: Parser UnionConv
parseUnion =
        Parser UnionConv
uFirst
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uNone
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uStrict
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure UnionConv
UFirst -- defaulting to UFirst
  where
    uFirst :: Parser UnionConv
uFirst  =  forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UFirst
            (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-first"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"The first value with the matching type (successfully parsed all the way down the tree) is accepted, even if not the only possible match. (DEFAULT)"
            )
    uNone :: Parser UnionConv
uNone   =  forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UNone
            (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-none"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Unions not allowed"
            )
    uStrict :: Parser UnionConv
uStrict =  forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UStrict
            (  forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-strict"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
O.help String
"Error if more than one union values match the type (and parse successfully)"
            )

-- ----------
-- Conversion
-- ----------

-- | JSON-to-dhall translation options
data Conversion = Conversion
    { Conversion -> Bool
strictRecs     :: Bool
    , Conversion -> Bool
noKeyValArr    :: Bool
    , Conversion -> Bool
noKeyValMap    :: Bool
    , Conversion -> UnionConv
unions         :: UnionConv
    , Conversion -> Bool
omissibleLists :: Bool
    } deriving Int -> Conversion -> ShowS
[Conversion] -> ShowS
Conversion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Conversion] -> ShowS
$cshowList :: [Conversion] -> ShowS
show :: Conversion -> String
$cshow :: Conversion -> String
showsPrec :: Int -> Conversion -> ShowS
$cshowsPrec :: Int -> Conversion -> ShowS
Show

data UnionConv = UFirst | UNone | UStrict deriving (Int -> UnionConv -> ShowS
[UnionConv] -> ShowS
UnionConv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnionConv] -> ShowS
$cshowList :: [UnionConv] -> ShowS
show :: UnionConv -> String
$cshow :: UnionConv -> String
showsPrec :: Int -> UnionConv -> ShowS
$cshowsPrec :: Int -> UnionConv -> ShowS
Show, ReadPrec [UnionConv]
ReadPrec UnionConv
Int -> ReadS UnionConv
ReadS [UnionConv]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UnionConv]
$creadListPrec :: ReadPrec [UnionConv]
readPrec :: ReadPrec UnionConv
$creadPrec :: ReadPrec UnionConv
readList :: ReadS [UnionConv]
$creadList :: ReadS [UnionConv]
readsPrec :: Int -> ReadS UnionConv
$creadsPrec :: Int -> ReadS UnionConv
Read, UnionConv -> UnionConv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionConv -> UnionConv -> Bool
$c/= :: UnionConv -> UnionConv -> Bool
== :: UnionConv -> UnionConv -> Bool
$c== :: UnionConv -> UnionConv -> Bool
Eq)

-- | Default conversion options
defaultConversion :: Conversion
defaultConversion :: Conversion
defaultConversion = Conversion
    { strictRecs :: Bool
strictRecs     = Bool
False
    , noKeyValArr :: Bool
noKeyValArr    = Bool
False
    , noKeyValMap :: Bool
noKeyValMap    = Bool
False
    , unions :: UnionConv
unions         = UnionConv
UFirst
    , omissibleLists :: Bool
omissibleLists = Bool
False
    }

-- | The 'Expr' type concretization used throughout this module
type ExprX = Expr Src Void

-- | Parse schema code and resolve imports
resolveSchemaExpr :: Text  -- ^ type code (schema)
                  -> IO ExprX
resolveSchemaExpr :: Text -> IO ExprX
resolveSchemaExpr Text
code = do
    Expr Src Import
parsedExpression <-
      case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText String
"\n\ESC[1;31mSCHEMA\ESC[0m" Text
code of
        Left  ParseError
err              -> forall e a. Exception e => e -> IO a
throwIO ParseError
err
        Right Expr Src Import
parsedExpression -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
parsedExpression
    Expr Src Import -> IO ExprX
Dhall.Import.load Expr Src Import
parsedExpression

{-| Check that the Dhall type expression actually has type 'Type'
>>> :set -XOverloadedStrings
>>> import Dhall.Core

>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "List Natural"
App List Natural

>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "+1"
*** Exception:
Error: Schema expression is successfully parsed but has Dhall type:
Integer
Expected Dhall type: Type
Parsed expression: +1
-}
typeCheckSchemaExpr :: (Exception e, MonadCatch m)
                    => (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr :: forall e (m :: * -> *).
(Exception e, MonadCatch m) =>
(CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr CompileError -> e
compileException ExprX
expr =
  case forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
D.typeOf ExprX
expr of -- check if the expression has type
    Left  TypeError Src Void
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException forall a b. (a -> b) -> a -> b
$ TypeError Src Void -> CompileError
TypeError TypeError Src Void
err
    Right ExprX
t   -> case ExprX
t of -- check if the expression has type Type
      D.Const Const
D.Type -> forall (m :: * -> *) a. Monad m => a -> m a
return ExprX
expr
      ExprX
_              -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX -> CompileError
BadDhallType ExprX
t ExprX
expr

keyValMay :: Value -> Maybe (Text, Value)
keyValMay :: Value -> Maybe (Text, Value)
keyValMay (Aeson.Object Object
o) = do
     Aeson.String Text
k <- Text -> Object -> Maybe Value
JSON.Compat.lookupObject Text
"key" Object
o
     Value
v <- Text -> Object -> Maybe Value
JSON.Compat.lookupObject Text
"value" Object
o
     forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Value
v)
keyValMay Value
_ = forall a. Maybe a
Nothing

{-| Given a JSON `Value`, make a best-effort guess of what the matching Dhall
    type should be

    This is used by @{json,yaml}-to-dhall@ if the user does not supply a schema
    on the command line
-}
inferSchema :: Value -> Schema
inferSchema :: Value -> Schema
inferSchema (Aeson.Object Object
m) =
    let convertMap :: KeyMap a -> Map Text a
convertMap = forall k a. [(k, a)] -> Map k a
Data.Map.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. KeyMap a -> [(Text, a)]
JSON.Compat.mapToAscList

    in (RecordSchema -> Schema
Record forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Schema -> RecordSchema
RecordSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. KeyMap a -> Map Text a
convertMap) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Schema
inferSchema Object
m)
inferSchema (Aeson.Array Array
xs) =
    Schema -> Schema
List (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap Value -> Schema
inferSchema Array
xs)
inferSchema (Aeson.String Text
_) =
    Schema
Text
inferSchema (Aeson.Number Scientific
n) =
    case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n of
        Left (Double
_ :: Double) -> Schema
Double
        Right (Integer
integer :: Integer)
            | Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
integer -> Schema
Natural
            | Bool
otherwise    -> Schema
Integer
inferSchema (Aeson.Bool Bool
_) =
    Schema
Bool
inferSchema Value
Aeson.Null =
    Schema -> Schema
Optional forall a. Monoid a => a
mempty

-- | Aeson record type that `inferSchema` can infer
newtype RecordSchema =
    RecordSchema { RecordSchema -> Map Text Schema
getRecordSchema :: Data.Map.Map Text Schema }

instance Semigroup RecordSchema where
    RecordSchema Map Text Schema
l <> :: RecordSchema -> RecordSchema -> RecordSchema
<> RecordSchema Map Text Schema
r = Map Text Schema -> RecordSchema
RecordSchema Map Text Schema
m
      where
        -- The reason this is not @Just (Optional s)@ is to avoid creating a
        -- double `Optional` wrapper when unifying a @null@ field with an
        -- absent field.
        onMissing :: p -> Schema -> Maybe Schema
onMissing p
_ Schema
s = forall a. a -> Maybe a
Just (Schema
s forall a. Semigroup a => a -> a -> a
<> Schema -> Schema
Optional forall a. Monoid a => a
mempty)

        m :: Map Text Schema
m = forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Data.Map.Merge.merge
                (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Data.Map.Merge.mapMaybeMissing forall {p}. p -> Schema -> Maybe Schema
onMissing)
                (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Data.Map.Merge.mapMaybeMissing forall {p}. p -> Schema -> Maybe Schema
onMissing)
                (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Data.Map.Merge.zipWithMatched (\Text
_ -> forall a. Semigroup a => a -> a -> a
(<>)))
                Map Text Schema
l
                Map Text Schema
r

recordSchemaToDhallType :: RecordSchema -> Expr s a
recordSchemaToDhallType :: forall s a. RecordSchema -> Expr s a
recordSchemaToDhallType (RecordSchema Map Text Schema
m) =
    forall s a. Map Text (RecordField s a) -> Expr s a
D.Record (forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList (forall k a. Map k a -> [(k, a)]
Data.Map.toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. Expr s a -> RecordField s a
D.makeRecordField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Schema -> Expr s a
schemaToDhallType) Map Text Schema
m)))

{-| `inferSchema` will never infer a union type with more than one numeric
    alternative

    Instead, the most general alternative type will be preferred, which this
    type tracks
-}
data UnionNumber
    = UnionAbsent
    -- ^ The union type does not have a numeric alternative
    | UnionNatural
    -- ^ The union type has a @Natural@ alternative
    | UnionInteger
    -- ^ The union type has an @Integer@ alternative
    | UnionDouble
    -- ^ The union type has a @Double@ alternative
    deriving (UnionNumber
forall a. a -> a -> Bounded a
maxBound :: UnionNumber
$cmaxBound :: UnionNumber
minBound :: UnionNumber
$cminBound :: UnionNumber
Bounded, UnionNumber -> UnionNumber -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionNumber -> UnionNumber -> Bool
$c/= :: UnionNumber -> UnionNumber -> Bool
== :: UnionNumber -> UnionNumber -> Bool
$c== :: UnionNumber -> UnionNumber -> Bool
Eq, Eq UnionNumber
UnionNumber -> UnionNumber -> Bool
UnionNumber -> UnionNumber -> Ordering
UnionNumber -> UnionNumber -> UnionNumber
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnionNumber -> UnionNumber -> UnionNumber
$cmin :: UnionNumber -> UnionNumber -> UnionNumber
max :: UnionNumber -> UnionNumber -> UnionNumber
$cmax :: UnionNumber -> UnionNumber -> UnionNumber
>= :: UnionNumber -> UnionNumber -> Bool
$c>= :: UnionNumber -> UnionNumber -> Bool
> :: UnionNumber -> UnionNumber -> Bool
$c> :: UnionNumber -> UnionNumber -> Bool
<= :: UnionNumber -> UnionNumber -> Bool
$c<= :: UnionNumber -> UnionNumber -> Bool
< :: UnionNumber -> UnionNumber -> Bool
$c< :: UnionNumber -> UnionNumber -> Bool
compare :: UnionNumber -> UnionNumber -> Ordering
$ccompare :: UnionNumber -> UnionNumber -> Ordering
Ord)

-- | Unify two numeric alternative types by preferring the most general type
instance Semigroup UnionNumber where
    <> :: UnionNumber -> UnionNumber -> UnionNumber
(<>) = forall a. Ord a => a -> a -> a
max

instance Monoid UnionNumber where
    mempty :: UnionNumber
mempty = forall a. Bounded a => a
minBound

unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]
unionNumberToAlternatives :: forall s a. UnionNumber -> [(Text, Maybe (Expr s a))]
unionNumberToAlternatives UnionNumber
UnionAbsent  = []
unionNumberToAlternatives UnionNumber
UnionNatural = [ (Text
"Natural", forall a. a -> Maybe a
Just forall s a. Expr s a
D.Natural) ]
unionNumberToAlternatives UnionNumber
UnionInteger = [ (Text
"Integer", forall a. a -> Maybe a
Just forall s a. Expr s a
D.Integer) ]
unionNumberToAlternatives UnionNumber
UnionDouble  = [ (Text
"Double" , forall a. a -> Maybe a
Just forall s a. Expr s a
D.Double ) ]

{-| A union type that `inferSchema` can infer

    This type will have at most three alternatives:

    * A @Bool@ alternative
    * Either a @Natural@, @Integer@, or @Double@ alternative
    * A @Text@ alternative

    These alternatives will always use the same names and types when we convert
    back to a Dhall type, so we only need to keep track of whether or not each
    alternative is present.

    We only store simple types inside of a union since we treat any attempt to
    unify a simple type with a complex type as a strong indication that the
    user intended for the schema to be `ArbitraryJSON`.
-}
data UnionSchema = UnionSchema
    { UnionSchema -> Any
bool :: Any
    -- ^ `True` if the union has a @Bool@ alternative
    , UnionSchema -> UnionNumber
number :: UnionNumber
    -- ^ Up to one numeric alternative
    , UnionSchema -> Any
text :: Any
    -- ^ `True` if the union has a @Text@ alternative
    } deriving (UnionSchema -> UnionSchema -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionSchema -> UnionSchema -> Bool
$c/= :: UnionSchema -> UnionSchema -> Bool
== :: UnionSchema -> UnionSchema -> Bool
$c== :: UnionSchema -> UnionSchema -> Bool
Eq)

unionSchemaToDhallType :: UnionSchema -> Expr s a
unionSchemaToDhallType :: forall s a. UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: UnionSchema -> Any
number :: UnionSchema -> UnionNumber
bool :: UnionSchema -> Any
..} = forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
D.Union (forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList forall {s} {a}. [(Text, Maybe (Expr s a))]
alternatives)
  where
    alternatives :: [(Text, Maybe (Expr s a))]
alternatives =
            (if Any -> Bool
getAny Any
bool then [ (Text
"Bool", forall a. a -> Maybe a
Just forall s a. Expr s a
D.Bool) ] else [])
        forall a. Semigroup a => a -> a -> a
<>  forall s a. UnionNumber -> [(Text, Maybe (Expr s a))]
unionNumberToAlternatives UnionNumber
number
        forall a. Semigroup a => a -> a -> a
<>  (if Any -> Bool
getAny Any
text then [ (Text
"Text", forall a. a -> Maybe a
Just forall s a. Expr s a
D.Text) ] else [])

-- | Unify two union types by combining their alternatives
instance Semigroup UnionSchema where
    UnionSchema Any
boolL UnionNumber
numberL Any
textL <> :: UnionSchema -> UnionSchema -> UnionSchema
<> UnionSchema Any
boolR UnionNumber
numberR Any
textR =
        UnionSchema{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: Any
number :: UnionNumber
bool :: Any
..}
      where
        bool :: Any
bool = Any
boolL forall a. Semigroup a => a -> a -> a
<> Any
boolR

        number :: UnionNumber
number = UnionNumber
numberL forall a. Semigroup a => a -> a -> a
<> UnionNumber
numberR

        text :: Any
text = Any
textL forall a. Semigroup a => a -> a -> a
<> Any
textR

instance Monoid UnionSchema where
    mempty :: UnionSchema
mempty = UnionSchema{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: Any
number :: UnionNumber
bool :: Any
..}
      where
        bool :: Any
bool = forall a. Monoid a => a
mempty

        number :: UnionNumber
number = forall a. Monoid a => a
mempty

        text :: Any
text = forall a. Monoid a => a
mempty

{-| A `Schema` is a subset of the `Expr` type representing all possible
    Dhall types that `inferSchema` could potentially return
-}
data Schema
    = Bool
    | Natural
    | Integer
    | Double
    | Text
    | List Schema
    | Optional Schema
    | Record RecordSchema
    | Union UnionSchema
    | ArbitraryJSON

-- | (`<>`) unifies two schemas
instance Semigroup Schema where
    -- `ArbitraryJSON` subsumes every other type
    Schema
ArbitraryJSON <> :: Schema -> Schema -> Schema
<> Schema
_ = Schema
ArbitraryJSON
    Schema
_ <> Schema
ArbitraryJSON = Schema
ArbitraryJSON

    -- Simple types unify with themselves
    Schema
Bool    <> Schema
Bool    = Schema
Bool
    Schema
Text    <> Schema
Text    = Schema
Text
    Schema
Natural <> Schema
Natural = Schema
Natural
    Schema
Integer <> Schema
Integer = Schema
Integer
    Schema
Double  <> Schema
Double  = Schema
Double

    -- Complex types unify with themselves
    Record   RecordSchema
l <> Record   RecordSchema
r = RecordSchema -> Schema
Record   (RecordSchema
l forall a. Semigroup a => a -> a -> a
<> RecordSchema
r)
    List     Schema
l <> List     Schema
r = Schema -> Schema
List     (Schema
l forall a. Semigroup a => a -> a -> a
<> Schema
r)
    Union    UnionSchema
l <> Union    UnionSchema
r = UnionSchema -> Schema
Union    (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Optional Schema
l <> Optional Schema
r = Schema -> Schema
Optional (Schema
l forall a. Semigroup a => a -> a -> a
<> Schema
r)

    -- Numeric types unify on the most general numeric type
    Schema
Natural <> Schema
Integer = Schema
Integer
    Schema
Integer <> Schema
Natural = Schema
Integer
    Schema
Natural <> Schema
Double  = Schema
Double
    Schema
Integer <> Schema
Double  = Schema
Double
    Schema
Double  <> Schema
Natural = Schema
Double
    Schema
Double  <> Schema
Integer = Schema
Double

    -- Unifying two different simple types produces a union
    Schema
Bool    <> Schema
Natural = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionNatural }
    Schema
Bool    <> Schema
Integer = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionInteger }
    Schema
Bool    <> Schema
Double  = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionDouble }
    Schema
Bool    <> Schema
Text    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Natural <> Schema
Bool    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionNatural }
    Schema
Natural <> Schema
Text    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Integer <> Schema
Bool    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionInteger }
    Schema
Integer <> Schema
Text    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Double  <> Schema
Bool    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionDouble }
    Schema
Double  <> Schema
Text    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Text    <> Schema
Bool    = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Text    <> Schema
Natural = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Text    <> Schema
Integer = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger, text :: Any
text = Bool -> Any
Any Bool
True }
    Schema
Text    <> Schema
Double  = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble, text :: Any
text = Bool -> Any
Any Bool
True }

    -- The empty union type is the identity of unification
    Union UnionSchema
l <> Schema
r | UnionSchema
l forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = Schema
r
    Schema
l <> Union UnionSchema
r | UnionSchema
r forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = Schema
l

    -- Unifying a simple type with a union adds the simple type as yet another
    -- alternative
    Schema
Bool    <> Union UnionSchema
r = UnionSchema -> Schema
Union (forall a. Monoid a => a
mempty{ bool :: Any
bool   = Bool -> Any
Any Bool
True } forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Schema
Natural <> Union UnionSchema
r = UnionSchema -> Schema
Union (forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural } forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Schema
Integer <> Union UnionSchema
r = UnionSchema -> Schema
Union (forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger } forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Schema
Double  <> Union UnionSchema
r = UnionSchema -> Schema
Union (forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble} forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Schema
Text    <> Union UnionSchema
r = UnionSchema -> Schema
Union (forall a. Monoid a => a
mempty{ text :: Any
text   = Bool -> Any
Any Bool
True } forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
    Union UnionSchema
l <> Schema
Bool    = UnionSchema -> Schema
Union (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a
mempty{ bool :: Any
bool   = Bool -> Any
Any Bool
True })
    Union UnionSchema
l <> Schema
Natural = UnionSchema -> Schema
Union (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural })
    Union UnionSchema
l <> Schema
Integer = UnionSchema -> Schema
Union (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger })
    Union UnionSchema
l <> Schema
Double  = UnionSchema -> Schema
Union (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble })
    Union UnionSchema
l <> Schema
Text    = UnionSchema -> Schema
Union (UnionSchema
l forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a
mempty{ text :: Any
text   = Bool -> Any
Any Bool
True })

    -- All of the remaining cases are for unifying simple types with
    -- complex types.  The only such case that can be sensibly unified is for
    -- `Optional`

    -- `Optional` subsumes every type other than `ArbitraryJSON`
    Optional Schema
l <> Schema
r = Schema -> Schema
Optional (Schema
l forall a. Semigroup a => a -> a -> a
<> Schema
r)
    Schema
l <> Optional Schema
r = Schema -> Schema
Optional (Schema
l forall a. Semigroup a => a -> a -> a
<> Schema
r)

    -- For all other cases, a simple type cannot be unified with a complex
    -- type, so fall back to `ArbitraryJSON`
    --
    -- This is equivalent to:
    --
    --     _ <> _ = ArbitraryJSON
    --
    -- ... but more explicit, in order to minimize the chance of ignoring an
    -- important case by accident.
    List Schema
_   <> Schema
_        = Schema
ArbitraryJSON
    Schema
_        <> List Schema
_   = Schema
ArbitraryJSON
    Record RecordSchema
_ <> Schema
_        = Schema
ArbitraryJSON
    Schema
_        <> Record RecordSchema
_ = Schema
ArbitraryJSON

instance Monoid Schema where
    mempty :: Schema
mempty = UnionSchema -> Schema
Union forall a. Monoid a => a
mempty

-- | Convert a `Schema` to the corresponding Dhall type
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType :: forall s a. Schema -> Expr s a
schemaToDhallType Schema
Bool = forall s a. Expr s a
D.Bool
schemaToDhallType Schema
Natural = forall s a. Expr s a
D.Natural
schemaToDhallType Schema
Integer = forall s a. Expr s a
D.Integer
schemaToDhallType Schema
Double = forall s a. Expr s a
D.Double
schemaToDhallType Schema
Text = forall s a. Expr s a
D.Text
schemaToDhallType (List Schema
a) = forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Schema -> Expr s a
schemaToDhallType Schema
a)
schemaToDhallType (Optional Schema
a) = forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.Optional (forall s a. Schema -> Expr s a
schemaToDhallType Schema
a)
schemaToDhallType (Record RecordSchema
r) = forall s a. RecordSchema -> Expr s a
recordSchemaToDhallType RecordSchema
r
schemaToDhallType (Union UnionSchema
u) = forall s a. UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema
u
schemaToDhallType Schema
ArbitraryJSON =
    forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Const -> Expr s a
D.Const Const
D.Type)
        (forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_"
            (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                [ (Text
"array" , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Int -> Expr s a
V Int
0)) (forall s a. Int -> Expr s a
V Int
1))
                , (Text
"bool"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Bool (forall s a. Int -> Expr s a
V Int
1))
                , (Text
"double", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Double (forall s a. Int -> Expr s a
V Int
1))
                , (Text
"integer", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Integer (forall s a. Int -> Expr s a
V Int
1))
                , (Text
"null"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Int -> Expr s a
V Int
0)
                , (Text
"object", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$
                    forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                        [ (Text
"mapKey", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall s a. Expr s a
D.Text)
                        , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Int -> Expr s a
V Int
0)
                        ])) (forall s a. Int -> Expr s a
V Int
1))
                , (Text
"string", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Text (forall s a. Int -> Expr s a
V Int
1))
                ]
            )
            (forall s a. Int -> Expr s a
V Int
1)
        )

{-| The main conversion function. Traversing\/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options:

>>> :set -XOverloadedStrings
>>> import qualified Dhall.Core as D
>>> import qualified Dhall.Map as Map
>>> import qualified Data.Aeson as Aeson
>>> import qualified Data.HashMap.Strict as HM

>>> s = D.Record (Map.fromList [("foo", D.Integer)])
>>> v = Aeson.Object (HM.fromList [("foo", Aeson.Number 1)])
>>> dhallFromJSON defaultConversion s v
Right (RecordLit (fromList [("foo",IntegerLit 1)]))

-}
dhallFromJSON
  :: Conversion -> ExprX -> Value -> Either CompileError ExprX
dhallFromJSON :: Conversion -> ExprX -> Value -> Either CompileError ExprX
dhallFromJSON (Conversion {Bool
UnionConv
omissibleLists :: Bool
unions :: UnionConv
noKeyValMap :: Bool
noKeyValArr :: Bool
strictRecs :: Bool
omissibleLists :: Conversion -> Bool
unions :: Conversion -> UnionConv
noKeyValMap :: Conversion -> Bool
noKeyValArr :: Conversion -> Bool
strictRecs :: Conversion -> Bool
..}) ExprX
expressionType =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
Optics.rewriteOf forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
D.subExpressions forall s a. Expr s a -> Maybe (Expr s a)
Lint.useToMap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop [] (forall s a. Expr s a -> Expr s a
D.alphaNormalize (forall a s t. Eq a => Expr s a -> Expr t a
D.normalize ExprX
expressionType))
  where
    loop :: Aeson.Types.JSONPath -> ExprX -> Aeson.Value -> Either CompileError ExprX
    -- any ~> Union
    loop :: JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath t :: ExprX
t@(D.Union Map Text (Maybe ExprX)
tm) Value
v = do
      let f :: Text -> Maybe ExprX -> Either CompileError ExprX
f Text
key Maybe ExprX
maybeType =
            case Maybe ExprX
maybeType of
              Just ExprX
_type -> do
                ExprX
expression <- JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
_type Value
v

                forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
t forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
key) ExprX
expression)

              Maybe ExprX
Nothing ->
                case Value
v of
                    Aeson.String Text
text | Text
key forall a. Eq a => a -> a -> Bool
== Text
text ->
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
t forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
key)
                    Value
_ ->
                        forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)

      case (UnionConv
unions, forall a b. [Either a b] -> [b]
rights (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> Maybe ExprX -> Either CompileError ExprX
f Map Text (Maybe ExprX)
tm))) of
        (UnionConv
UNone  , [ExprX]
_         ) -> forall a b. a -> Either a b
Left (ExprX -> CompileError
ContainsUnion ExprX
t)
        (UnionConv
UStrict, xs :: [ExprX]
xs@(ExprX
_:ExprX
_:[ExprX]
_)) -> forall a b. a -> Either a b
Left (ExprX -> Value -> [ExprX] -> CompileError
UndecidableUnion ExprX
t Value
v [ExprX]
xs)
        (UnionConv
_      , [ ]       ) -> forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
        (UnionConv
UFirst , ExprX
x:[ExprX]
_       ) -> forall a b. b -> Either a b
Right ExprX
x
        (UnionConv
UStrict, [Item [ExprX]
x]       ) -> forall a b. b -> Either a b
Right Item [ExprX]
x

    -- object ~> Record
    loop JSONPath
jsonPath (D.Record Map Text (RecordField Src Void)
r) v :: Value
v@(Aeson.Object Object
o)
        | [Text]
extraKeys <- Object -> [Text]
JSON.Compat.objectKeys Object
o forall a. Eq a => [a] -> [a] -> [a]
\\ forall k v. Map k v -> [k]
Map.keys Map Text (RecordField Src Void)
r
        , Bool
strictRecs Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
extraKeys)
        = forall a b. a -> Either a b
Left ([Text] -> ExprX -> Value -> JSONPath -> CompileError
UnhandledKeys [Text]
extraKeys (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record Map Text (RecordField Src Void)
r) Value
v JSONPath
jsonPath)
        | Bool
otherwise
        = let f :: Text -> ExprX -> Either CompileError ExprX
              f :: Text -> ExprX -> Either CompileError ExprX
f Text
k ExprX
t | Just Value
value <- Text -> Object -> Maybe Value
JSON.Compat.lookupObject Text
k Object
o
                    = JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Key -> JSONPathElement
Aeson.Types.Key (Text -> Key
JSON.Compat.textToKey Text
k) forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
t Value
value
                    | App ExprX
D.Optional ExprX
t' <- ExprX
t
                    = forall a b. b -> Either a b
Right (forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
D.None ExprX
t')
                    | App ExprX
D.List ExprX
_ <- ExprX
t
                    , Bool
omissibleLists
                    = forall a b. b -> Either a b
Right (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit (forall a. a -> Maybe a
Just ExprX
t) [])
                    | Bool
otherwise
                    = forall a b. a -> Either a b
Left (Text -> ExprX -> Value -> JSONPath -> CompileError
MissingKey Text
k ExprX
t Value
v JSONPath
jsonPath)
           in forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. Expr s a -> RecordField s a
D.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
(k -> a -> f b) -> Map k a -> f (Map k b)
Map.traverseWithKey Text -> ExprX -> Either CompileError ExprX
f (forall s a. RecordField s a -> Expr s a
D.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Src Void)
r)

    -- key-value list ~> Record
    loop JSONPath
jsonPath t :: ExprX
t@(D.Record Map Text (RecordField Src Void)
_) v :: Value
v@(Aeson.Array Array
a)
        | Bool -> Bool
not Bool
noKeyValArr
        , [Value]
os :: [Value] <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a
        , Just [(Text, Value)]
kvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Maybe (Text, Value)
keyValMay [Value]
os
        = JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
t (Object -> Value
Aeson.Object forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
JSON.Compat.objectFromList [(Text, Value)]
kvs)
        | Bool
noKeyValArr
        = forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
NoKeyValArray ExprX
t Value
v)
        | Bool
otherwise
        = forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)

    -- object ~> List (key, value)
    loop JSONPath
jsonPath t :: ExprX
t@(App ExprX
D.List (D.Record Map Text (RecordField Src Void)
r)) v :: Value
v@(Aeson.Object Object
o)
        | Bool -> Bool
not Bool
noKeyValMap
        , [Text
"mapKey", Text
"mapValue"] forall a. Eq a => a -> a -> Bool
== forall k v. Map k v -> [k]
Map.keys Map Text (RecordField Src Void)
r
        , Just ExprX
mapKey   <- forall s a. RecordField s a -> Expr s a
D.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"mapKey" Map Text (RecordField Src Void)
r
        , Just ExprX
mapValue <- forall s a. RecordField s a -> Expr s a
D.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"mapValue" Map Text (RecordField Src Void)
r
        = do
          KeyMap ExprX
keyExprMap <- forall (f :: * -> *) v1 v2.
Applicative f =>
(Key -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)
JSON.Compat.traverseObjectWithKey (\Key
k Value
child -> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Key -> JSONPathElement
Aeson.Types.Key Key
k forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
mapValue Value
child) Object
o

          Text -> ExprX
toKey <-
              case ExprX
mapKey of
                  ExprX
D.Text    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
D.TextLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks []
                  D.Union Map Text (Maybe ExprX)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
mapKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Text -> FieldSelection s
FA
                  ExprX
_         -> forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)

          let f :: (Text, ExprX) -> ExprX
              f :: (Text, ExprX) -> ExprX
f (Text
key, ExprX
val) = forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
D.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList
                  [ (Text
"mapKey"  , Text -> ExprX
toKey Text
key)
                  , (Text
"mapValue", ExprX
val)
                  ]

          let records :: Seq ExprX
records =
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, ExprX) -> ExprX
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Seq a
Seq.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. KeyMap a -> [(Text, a)]
JSON.Compat.mapToAscList) KeyMap ExprX
keyExprMap

          let typeAnn :: Maybe ExprX
typeAnn = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Object
o then forall a. a -> Maybe a
Just ExprX
t else forall a. Maybe a
Nothing

          forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit Maybe ExprX
typeAnn Seq ExprX
records)
        | Bool
noKeyValMap
        = forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
NoKeyValMap ExprX
t Value
v)
        | Bool
otherwise
        = forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)

    -- array ~> List
    loop JSONPath
jsonPath (App ExprX
D.List ExprX
t) (Aeson.Array Array
a)
        = let f :: [ExprX] -> ExprX
              f :: [ExprX] -> ExprX
f [ExprX]
es = forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit
                       (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExprX]
es then forall a. a -> Maybe a
Just (forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
D.List ExprX
t) else forall a. Maybe a
Nothing)
                       (forall a. [a] -> Seq a
Seq.fromList [ExprX]
es)
           in [ExprX] -> ExprX
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Int
idx, Value
val) -> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Int -> JSONPathElement
Aeson.Types.Index Int
idx forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
t Value
val) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a)

    -- null ~> List
    loop JSONPath
jsonPath t :: ExprX
t@(App ExprX
D.List ExprX
_) Value
Aeson.Null
        = if Bool
omissibleLists
          then forall a b. b -> Either a b
Right (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit (forall a. a -> Maybe a
Just ExprX
t) [])
          else forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
Aeson.Null JSONPath
jsonPath)

    -- number ~> Integer
    loop JSONPath
jsonPath ExprX
D.Integer (Aeson.Number Scientific
x)
        | Right Integer
n <- forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
x :: Either Double Integer
        = forall a b. b -> Either a b
Right (forall s a. Integer -> Expr s a
D.IntegerLit Integer
n)
        | Bool
otherwise
        = forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch forall s a. Expr s a
D.Integer (Scientific -> Value
Aeson.Number Scientific
x) JSONPath
jsonPath)

    -- number ~> Natural
    loop JSONPath
jsonPath ExprX
D.Natural (Aeson.Number Scientific
x)
        | Right Integer
n <- forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
x :: Either Double Integer
        , Integer
n forall a. Ord a => a -> a -> Bool
>= Integer
0
        = forall a b. b -> Either a b
Right (forall s a. Natural -> Expr s a
D.NaturalLit (forall a. Num a => Integer -> a
fromInteger Integer
n))
        | Bool
otherwise
        = forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch forall s a. Expr s a
D.Natural (Scientific -> Value
Aeson.Number Scientific
x) JSONPath
jsonPath)

    -- number ~> Double
    loop JSONPath
_ ExprX
D.Double (Aeson.Number Scientific
x)
        = forall a b. b -> Either a b
Right (forall s a. DhallDouble -> Expr s a
D.DoubleLit forall a b. (a -> b) -> a -> b
$ Double -> DhallDouble
DhallDouble forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
x)

    -- string ~> Text
    loop JSONPath
_ ExprX
D.Text (Aeson.String Text
t)
        = forall a b. b -> Either a b
Right (forall s a. Chunks s a -> Expr s a
D.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
t))

    -- bool ~> Bool
    loop JSONPath
_ ExprX
D.Bool (Aeson.Bool Bool
t)
        = forall a b. b -> Either a b
Right (forall s a. Bool -> Expr s a
D.BoolLit Bool
t)

    -- null ~> Optional
    loop JSONPath
_ (App ExprX
D.Optional ExprX
expr) Value
Aeson.Null
        = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
D.None ExprX
expr

    -- value ~> Optional
    loop JSONPath
jsonPath (App ExprX
D.Optional ExprX
expr) Value
value
        = forall s a. Expr s a -> Expr s a
D.Some forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
expr Value
value

    -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (< v13.0.0)
    loop
      JSONPath
_
      (D.Pi Maybe CharacterSet
_ Text
_ (D.Const Const
D.Type)
          (D.Pi Maybe CharacterSet
_ Text
_
              (D.Record
                  [ (Text
"array" , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ (D.App ExprX
D.List (V Int
0)) (V Int
1))
                  , (Text
"bool"  , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Bool (V Int
1))
                  , (Text
"null"  , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> V Int
0)
                  , (Text
"number", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Double (V Int
1))
                  , (Text
"object", forall s a. RecordField s a -> Expr s a
D.recordFieldValue ->
                      D.Pi Maybe CharacterSet
_ Text
_ (D.App ExprX
D.List (D.Record
                      [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> ExprX
D.Text)
                      , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> V Int
0)
                      ])) (V Int
1))
                  , (Text
"string", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Text (V Int
1))
                  ]
              )
              (V Int
1)
          )
      )
      Value
value = do
          let outer :: Value -> Expr s a
outer (Aeson.Object Object
o) =
                  let inner :: (Text, Value) -> Expr s a
inner (Text
key, Value
val) =
                          forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit
                              [ (Text
"mapKey"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
D.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
D.Chunks [] Text
key))
                              , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ Value -> Expr s a
outer Value
val                  )
                              ]

                      elements :: Seq (Expr s a)
elements =
                          forall a. [a] -> Seq a
Seq.fromList
                              (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> Expr s a
inner
                                  (forall a. KeyMap a -> [(Text, a)]
JSON.Compat.mapToAscList Object
o)
                              )

                      elementType :: Maybe (Expr s a)
elementType
                          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
elements =
                              forall a. a -> Maybe a
Just (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                                [ (Text
"mapKey", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall s a. Expr s a
D.Text)
                                , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
                                ]))
                          | Bool
otherwise =
                              forall a. Maybe a
Nothing

                      keyValues :: Expr s a
keyValues = forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit forall {s} {a}. Maybe (Expr s a)
elementType Seq (Expr s a)
elements

                  in  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"object") Expr s a
keyValues
              outer (Aeson.Array Array
a) =
                  let elements :: Seq (Expr s a)
elements = forall a. [a] -> Seq a
Seq.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Expr s a
outer (forall a. Vector a -> [a]
Vector.toList Array
a))

                      elementType :: Maybe (Expr s a)
elementType
                          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
elements = forall a. a -> Maybe a
Just (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List Expr s a
"JSON")
                          | Bool
otherwise     = forall a. Maybe a
Nothing

                  in  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"array") (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit forall {s} {a}. Maybe (Expr s a)
elementType Seq (Expr s a)
elements)
              outer (Aeson.String Text
s) =
                  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"string") (forall s a. Chunks s a -> Expr s a
D.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
D.Chunks [] Text
s))
              outer (Aeson.Number Scientific
n) =
                  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"number") (forall s a. DhallDouble -> Expr s a
D.DoubleLit (Double -> DhallDouble
DhallDouble (forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
n)))
              outer (Aeson.Bool Bool
b) =
                  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"bool") (forall s a. Bool -> Expr s a
D.BoolLit Bool
b)
              outer Value
Aeson.Null =
                  forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
FA Text
"null"

          let result :: Expr s a
result =
                forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam forall a. Monoid a => a
mempty (forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"JSON" (forall s a. Const -> Expr s a
D.Const Const
D.Type))
                    (forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam forall a. Monoid a => a
mempty (forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"json"
                        (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                            [ (Text
"array" , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List Expr s a
"JSON") Expr s a
"JSON")
                            , (Text
"bool"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Bool Expr s a
"JSON")
                            , (Text
"null"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
                            , (Text
"number", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Double Expr s a
"JSON")
                            , (Text
"object", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$
                                forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                                    [ (Text
"mapKey", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall s a. Expr s a
D.Text)
                                    , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
                                    ])) Expr s a
"JSON")
                            , (Text
"string", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Text Expr s a
"JSON")
                            ]
                        ))
                        (forall {s} {a}. Value -> Expr s a
outer Value
value)
                    )

          forall (m :: * -> *) a. Monad m => a -> m a
return forall s a. Expr s a
result

    -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (v13.0.0 <=)
    loop
      JSONPath
_
      (D.Pi Maybe CharacterSet
_ Text
_ (D.Const Const
D.Type)
          (D.Pi Maybe CharacterSet
_ Text
_
              (D.Record
                  [ (Text
"array" , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ (D.App ExprX
D.List (V Int
0)) (V Int
1))
                  , (Text
"bool"  , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Bool (V Int
1))
                  , (Text
"double", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Double (V Int
1))
                  , (Text
"integer", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Integer (V Int
1))
                  , (Text
"null"  , forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> V Int
0)
                  , (Text
"object", forall s a. RecordField s a -> Expr s a
D.recordFieldValue ->
                      D.Pi Maybe CharacterSet
_ Text
_ (D.App ExprX
D.List (D.Record
                        [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> ExprX
D.Text)
                        , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> V Int
0)
                        ])) (V Int
1))
                  , (Text
"string", forall s a. RecordField s a -> Expr s a
D.recordFieldValue -> D.Pi Maybe CharacterSet
_ Text
_ ExprX
D.Text (V Int
1))
                  ]
              )
              (V Int
1)
          )
      )
      Value
value = do
          let outer :: Value -> Expr s a
outer (Aeson.Object Object
o) =
                  let inner :: (Text, Value) -> Expr s a
inner (Text
key, Value
val) =
                          forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit
                              [ (Text
"mapKey"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
D.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
D.Chunks [] Text
key))
                              , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ Value -> Expr s a
outer Value
val                  )
                              ]

                      elements :: Seq (Expr s a)
elements =
                          forall a. [a] -> Seq a
Seq.fromList
                              (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> Expr s a
inner
                                  (forall a. KeyMap a -> [(Text, a)]
JSON.Compat.mapToAscList Object
o)
                              )

                      elementType :: Maybe (Expr s a)
elementType
                          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
elements =
                              forall a. a -> Maybe a
Just (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                                [ (Text
"mapKey", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall s a. Expr s a
D.Text)
                                , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON") ]))
                          | Bool
otherwise =
                              forall a. Maybe a
Nothing

                      keyValues :: Expr s a
keyValues = forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit forall {s} {a}. Maybe (Expr s a)
elementType Seq (Expr s a)
elements

                  in  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"object")) Expr s a
keyValues
              outer (Aeson.Array Array
a) =
                  let elements :: Seq (Expr s a)
elements = forall a. [a] -> Seq a
Seq.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Expr s a
outer (forall a. Vector a -> [a]
Vector.toList Array
a))

                      elementType :: Maybe (Expr s a)
elementType
                          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
elements = forall a. a -> Maybe a
Just (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List Expr s a
"JSON")
                          | Bool
otherwise     = forall a. Maybe a
Nothing

                  in  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"array")) (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit forall {s} {a}. Maybe (Expr s a)
elementType Seq (Expr s a)
elements)
              outer (Aeson.String Text
s) =
                  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"string")) (forall s a. Chunks s a -> Expr s a
D.TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
D.Chunks [] Text
s))
              outer (Aeson.Number Scientific
n) =
                  case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n of
                      Left Double
floating -> forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"double")) (forall s a. DhallDouble -> Expr s a
D.DoubleLit (Double -> DhallDouble
DhallDouble Double
floating))
                      Right Integer
integer -> forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"integer")) (forall s a. Integer -> Expr s a
D.IntegerLit Integer
integer)
              outer (Aeson.Bool Bool
b) =
                  forall s a. Expr s a -> Expr s a -> Expr s a
D.App (forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"bool")) (forall s a. Bool -> Expr s a
D.BoolLit Bool
b)
              outer Value
Aeson.Null =
                  forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (forall s. Text -> FieldSelection s
FA Text
"null")

          let result :: Expr s a
result =
                forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam forall a. Monoid a => a
mempty (forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"JSON" (forall s a. Const -> Expr s a
D.Const Const
D.Type))
                    (forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam forall a. Monoid a => a
mempty (forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"json"
                        (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                            [ (Text
"array" , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List Expr s a
"JSON") Expr s a
"JSON")
                            , (Text
"bool"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Bool Expr s a
"JSON")
                            , (Text
"double", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Double Expr s a
"JSON")
                            , (Text
"integer", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Integer Expr s a
"JSON")
                            , (Text
"null"  , forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
                            , (Text
"object", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_"
                                (forall s a. Expr s a -> Expr s a -> Expr s a
D.App forall s a. Expr s a
D.List (forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
                                    [ (Text
"mapKey", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall s a. Expr s a
D.Text)
                                    , (Text
"mapValue", forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")])) Expr s a
"JSON")
                            , (Text
"string", forall s a. Expr s a -> RecordField s a
D.makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi forall a. Monoid a => a
mempty Text
"_" forall s a. Expr s a
D.Text Expr s a
"JSON")
                            ]
                        ))
                        (forall {s} {a}. Value -> Expr s a
outer Value
value)
                    )

          forall (m :: * -> *) a. Monad m => a -> m a
return forall s a. Expr s a
result

    -- fail
    loop JSONPath
jsonPath ExprX
expr Value
value
        = forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
expr Value
value JSONPath
jsonPath)


-- ----------
-- EXCEPTIONS
-- ----------

red, purple, green
    :: (Semigroup a, Data.String.IsString a) => a -> a
red :: forall a. (Semigroup a, IsString a) => a -> a
red    a
s = a
"\ESC[1;31m" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
"\ESC[0m" -- bold
purple :: forall a. (Semigroup a, IsString a) => a -> a
purple a
s = a
"\ESC[1;35m" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
"\ESC[0m" -- bold
green :: forall a. (Semigroup a, IsString a) => a -> a
green  a
s = a
"\ESC[0;32m" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
"\ESC[0m" -- plain

showExpr :: ExprX   -> String
showExpr :: ExprX -> String
showExpr ExprX
dhall = Text -> String
Text.unpack (forall a. Pretty a => a -> Text
D.pretty ExprX
dhall)

showJSON :: Value -> String
showJSON :: Value -> String
showJSON Value
value = ByteString -> String
BSL8.unpack (forall a. ToJSON a => a -> ByteString
encodePretty Value
value)

data CompileError
  -- Dhall shema
  = TypeError (D.TypeError Src Void)
  | BadDhallType
      ExprX -- Expression type
      ExprX -- Whole expression
  -- generic mismatch (fallback)
  | Mismatch
      ExprX   -- Dhall expression
      Value -- Aeson value
      Aeson.Types.JSONPath -- JSON Path to the error
  -- record specific
  | MissingKey     Text  ExprX Value Aeson.Types.JSONPath
  | UnhandledKeys [Text] ExprX Value Aeson.Types.JSONPath
  | NoKeyValArray        ExprX Value
  | NoKeyValMap          ExprX Value
  -- union specific
  | ContainsUnion        ExprX
  | UndecidableUnion     ExprX Value [ExprX]

instance Show CompileError where
    show :: CompileError -> String
show = String -> (Value -> String) -> CompileError -> String
showCompileError String
"JSON" Value -> String
showJSON

instance Exception CompileError

showCompileError :: String -> (Value -> String) -> CompileError -> String
showCompileError :: String -> (Value -> String) -> CompileError -> String
showCompileError String
format Value -> String
showValue = let prefix :: String
prefix = forall a. (Semigroup a, IsString a) => a -> a
red String
"\nError: "
          in \case
    TypeError TypeError Src Void
e -> forall a. Show a => a -> String
show TypeError Src Void
e

    BadDhallType ExprX
t ExprX
e -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> String
"Schema expression is successfully parsed but has Dhall type:\n"
      forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
t forall a. Semigroup a => a -> a -> a
<> String
"\nExpected Dhall type: Type"
      forall a. Semigroup a => a -> a -> a
<> String
"\nParsed expression: "
      forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e forall a. Semigroup a => a -> a -> a
<> String
"\n"

    ContainsUnion ExprX
e -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> String
"Dhall type expression contains union type:\n"
      forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e forall a. Semigroup a => a -> a -> a
<> String
"\nwhile it is forbidden by option "
      forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
green String
"--unions-none\n"

    UndecidableUnion ExprX
e Value
v [ExprX]
xs -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> String
"More than one union component type matches " forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" value"
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nExpected Dhall type:\n" forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
":\n"  forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nPossible matches:\n\n" -- Showing all the allowed matches
      forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
sep forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
D.pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExprX]
xs)
        where sep :: Text
sep = forall a. (Semigroup a, IsString a) => a -> a
red Text
"\n--------\n" :: Text

    Mismatch ExprX
e Value
v JSONPath
jsonPath -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath forall a. Semigroup a => a -> a -> a
<> String
": Dhall type expression and " forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" value do not match:"
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nExpected Dhall type:\n" forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
":\n"  forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
      forall a. Semigroup a => a -> a -> a
<> String
"\n"

    MissingKey Text
k ExprX
e Value
v JSONPath
jsonPath -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath forall a. Semigroup a => a -> a -> a
<> String
": Key " forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
purple (Text -> String
Text.unpack Text
k) forall a. Semigroup a => a -> a -> a
<> String
", expected by Dhall type:\n"
      forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\nis not present in " forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" object:\n"
      forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v forall a. Semigroup a => a -> a -> a
<> String
"\n"

    UnhandledKeys [Text]
ks ExprX
e Value
v JSONPath
jsonPath -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath forall a. Semigroup a => a -> a -> a
<> String
": Key(s) " forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
purple (Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
ks))
      forall a. Semigroup a => a -> a -> a
<> String
" present in the " forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" object but not in the expected Dhall"
      forall a. Semigroup a => a -> a -> a
<> String
" record type. This is not allowed unless you enable the "
      forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
green String
"--records-loose" forall a. Semigroup a => a -> a -> a
<> String
" flag:"
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nExpected Dhall type:\n" forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
":\n"  forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
      forall a. Semigroup a => a -> a -> a
<> String
"\n"

    NoKeyValArray ExprX
e Value
v -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> String
"" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" (key-value) arrays cannot be converted to Dhall records under "
      forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
green String
"--no-keyval-arrays" forall a. Semigroup a => a -> a -> a
<> String
" flag"
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nExpected Dhall type:\n" forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
":\n"  forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
      forall a. Semigroup a => a -> a -> a
<> String
"\n"

    NoKeyValMap ExprX
e Value
v -> String
prefix
      forall a. Semigroup a => a -> a -> a
<> String
"Homogeneous " forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
" map objects cannot be converted to Dhall association lists under "
      forall a. Semigroup a => a -> a -> a
<> forall a. (Semigroup a, IsString a) => a -> a
green String
"--no-keyval-maps" forall a. Semigroup a => a -> a -> a
<> String
" flag"
      forall a. Semigroup a => a -> a -> a
<> String
"\n\nExpected Dhall type:\n" forall a. Semigroup a => a -> a -> a
<> ExprX -> String
showExpr ExprX
e
      forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
format forall a. Semigroup a => a -> a -> a
<> String
":\n"  forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
      forall a. Semigroup a => a -> a -> a
<> String
"\n"

showJsonPath :: Aeson.Types.JSONPath -> String
showJsonPath :: JSONPath -> String
showJsonPath = JSONPath -> String
Aeson.Types.formatPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse