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

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


== 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 (throwM, MonadCatch)
import           Data.Aeson (Value)
import qualified Data.Aeson as A
import           Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BSL8
import           Data.Either (rights)
import           Data.Foldable (toList)
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HM
import           Data.List ((\\))
import qualified Data.List as List
import qualified Data.Map
import qualified Data.Map.Merge.Lazy as Data.Map.Merge
import           Data.Monoid (Any(..))
import qualified Data.Ord as Ord
import           Data.Scientific (floatingOrInteger, toRealFloat)
import           Data.Semigroup (Semigroup(..))
import qualified Data.Sequence as Seq
import qualified Data.String
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Vector as Vector
import           Data.Void (Void)
import qualified Options.Applicative as O
import           Options.Applicative (Parser)

import           Dhall.JSON.Util (pattern V)
import qualified Dhall.Core as D
import           Dhall.Core (Expr(App), Chunks(..), DhallDouble(..))
import qualified Dhall.Import
import qualified Dhall.Lint as Lint
import qualified Dhall.Map as Map
import qualified Dhall.Optics as Optics
import qualified Dhall.Parser
import           Dhall.Parser (Src)
import qualified Dhall.TypeCheck as D

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

    parseKVArr :: Parser Bool
parseKVArr  =  Mod FlagFields Bool -> Parser Bool
O.switch
                (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "no-keyval-arrays"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
O.help "Disable conversion of key-value arrays to records"
                )
    parseKVMap :: Parser Bool
parseKVMap  =  Mod FlagFields Bool -> Parser Bool
O.switch
                (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "no-keyval-maps"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
O.help "Disable conversion of homogeneous map objects to association lists"
                )
    parseOmissibleLists :: Parser Bool
parseOmissibleLists = Mod FlagFields Bool -> Parser Bool
O.switch
                          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "omissible-lists"
                          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
O.help "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
    Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uNone
    Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uStrict
    Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnionConv
UFirst -- defaulting to UFirst
  where
    uFirst :: Parser UnionConv
uFirst  =  UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UFirst
            (  String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "unions-first"
            Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)"
            )
    uNone :: Parser UnionConv
uNone   =  UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UNone
            (  String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "unions-none"
            Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help "Unions not allowed"
            )
    uStrict :: Parser UnionConv
uStrict =  UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UStrict
            (  String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long "unions-strict"
            Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help "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
(Int -> Conversion -> ShowS)
-> (Conversion -> String)
-> ([Conversion] -> ShowS)
-> Show Conversion
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
(Int -> UnionConv -> ShowS)
-> (UnionConv -> String)
-> ([UnionConv] -> ShowS)
-> Show UnionConv
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]
(Int -> ReadS UnionConv)
-> ReadS [UnionConv]
-> ReadPrec UnionConv
-> ReadPrec [UnionConv]
-> Read 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
(UnionConv -> UnionConv -> Bool)
-> (UnionConv -> UnionConv -> Bool) -> Eq UnionConv
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 :: Bool -> Bool -> Bool -> UnionConv -> Bool -> Conversion
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 code :: Text
code = do
    Expr Src Import
parsedExpression <-
      case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" Text
code of
        Left  err :: ParseError
err              -> ParseError -> IO (Expr Src Import)
forall e a. Exception e => e -> IO a
throwIO ParseError
err
        Right parsedExpression :: Expr Src Import
parsedExpression -> Expr Src Import -> IO (Expr Src Import)
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 :: (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr compileException :: CompileError -> e
compileException expr :: ExprX
expr =
  case ExprX -> Either (TypeError Src X) ExprX
forall s. Expr s X -> Either (TypeError s X) (Expr s X)
D.typeOf ExprX
expr of -- check if the expression has type
    Left  err :: TypeError Src X
err -> e -> m ExprX
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (e -> m ExprX) -> (CompileError -> e) -> CompileError -> m ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException (CompileError -> m ExprX) -> CompileError -> m ExprX
forall a b. (a -> b) -> a -> b
$ TypeError Src X -> CompileError
TypeError TypeError Src X
err
    Right t :: ExprX
t   -> case ExprX
t of -- check if the expression has type Type
      D.Const D.Type -> ExprX -> m ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return ExprX
expr
      _              -> e -> m ExprX
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (e -> m ExprX) -> (CompileError -> e) -> CompileError -> m ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException (CompileError -> m ExprX) -> CompileError -> m ExprX
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 (A.Object o :: Object
o) = do
     A.String k :: Text
k <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "key" Object
o
     Value
v <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "value" Object
o
     (Text, Value) -> Maybe (Text, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Value
v)
keyValMay _ = Maybe (Text, 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 (A.Object m :: Object
m) =
    let convertMap :: HashMap Text a -> Map Text a
convertMap = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList ([(Text, a)] -> Map Text a)
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

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

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

instance Semigroup RecordSchema where
    RecordSchema l :: Map Text Schema
l <> :: RecordSchema -> RecordSchema -> RecordSchema
<> RecordSchema r :: 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 _ s :: Schema
s = Schema -> Maybe Schema
forall a. a -> Maybe a
Just (Schema
s Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema -> Schema
Optional Schema
forall a. Monoid a => a
mempty)

        m :: Map Text Schema
m = SimpleWhenMissing Text Schema Schema
-> SimpleWhenMissing Text Schema Schema
-> SimpleWhenMatched Text Schema Schema Schema
-> Map Text Schema
-> Map Text Schema
-> Map Text Schema
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
                ((Text -> Schema -> Maybe Schema)
-> SimpleWhenMissing Text Schema Schema
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Data.Map.Merge.mapMaybeMissing Text -> Schema -> Maybe Schema
forall p. p -> Schema -> Maybe Schema
onMissing)
                ((Text -> Schema -> Maybe Schema)
-> SimpleWhenMissing Text Schema Schema
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Data.Map.Merge.mapMaybeMissing Text -> Schema -> Maybe Schema
forall p. p -> Schema -> Maybe Schema
onMissing)
                ((Text -> Schema -> Schema -> Schema)
-> SimpleWhenMatched Text Schema Schema Schema
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Data.Map.Merge.zipWithMatched (\_ -> Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
(<>)))
                Map Text Schema
l
                Map Text Schema
r

recordSchemaToDhallType :: RecordSchema -> Expr s a
recordSchemaToDhallType :: RecordSchema -> Expr s a
recordSchemaToDhallType (RecordSchema m :: Map Text Schema
m) =
    Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record ([(Text, Expr s a)] -> Map Text (Expr s a)
forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList (Map Text (Expr s a) -> [(Text, Expr s a)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList ((Schema -> Expr s a) -> Map Text Schema -> Map Text (Expr s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Expr s a
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
UnionNumber -> UnionNumber -> Bounded UnionNumber
forall a. a -> a -> Bounded a
maxBound :: UnionNumber
$cmaxBound :: UnionNumber
minBound :: UnionNumber
$cminBound :: UnionNumber
Bounded, UnionNumber -> UnionNumber -> Bool
(UnionNumber -> UnionNumber -> Bool)
-> (UnionNumber -> UnionNumber -> Bool) -> Eq UnionNumber
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
Eq UnionNumber =>
(UnionNumber -> UnionNumber -> Ordering)
-> (UnionNumber -> UnionNumber -> Bool)
-> (UnionNumber -> UnionNumber -> Bool)
-> (UnionNumber -> UnionNumber -> Bool)
-> (UnionNumber -> UnionNumber -> Bool)
-> (UnionNumber -> UnionNumber -> UnionNumber)
-> (UnionNumber -> UnionNumber -> UnionNumber)
-> Ord 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
$cp1Ord :: Eq UnionNumber
Ord)

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

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

    mappend :: UnionNumber -> UnionNumber -> UnionNumber
mappend = UnionNumber -> UnionNumber -> UnionNumber
forall a. Semigroup a => a -> a -> a
(<>)

unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]
unionNumberToAlternatives :: UnionNumber -> [(Text, Maybe (Expr s a))]
unionNumberToAlternatives UnionAbsent  = []
unionNumberToAlternatives UnionNatural = [ ("Natural", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
D.Natural) ]
unionNumberToAlternatives UnionInteger = [ ("Integer", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
D.Integer) ]
unionNumberToAlternatives UnionDouble  = [ ("Double" , Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
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
(UnionSchema -> UnionSchema -> Bool)
-> (UnionSchema -> UnionSchema -> Bool) -> Eq UnionSchema
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 :: UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema{..} = Map Text (Maybe (Expr s a)) -> Expr s a
forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
D.Union ([(Text, Maybe (Expr s a))] -> Map Text (Maybe (Expr s a))
forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList [(Text, Maybe (Expr s a))]
forall s a. [(Text, Maybe (Expr s a))]
alternatives)
  where
    alternatives :: [(Text, Maybe (Expr s a))]
alternatives =
            (if Any -> Bool
getAny Any
bool then [ ("Bool", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
D.Bool) ] else [])
        [(Text, Maybe (Expr s a))]
-> [(Text, Maybe (Expr s a))] -> [(Text, Maybe (Expr s a))]
forall a. Semigroup a => a -> a -> a
<>  UnionNumber -> [(Text, Maybe (Expr s a))]
forall s a. UnionNumber -> [(Text, Maybe (Expr s a))]
unionNumberToAlternatives UnionNumber
number
        [(Text, Maybe (Expr s a))]
-> [(Text, Maybe (Expr s a))] -> [(Text, Maybe (Expr s a))]
forall a. Semigroup a => a -> a -> a
<>  (if Any -> Bool
getAny Any
text then [ ("Text", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
D.Text) ] else [])

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

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

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

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

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

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

    mappend :: UnionSchema -> UnionSchema -> UnionSchema
mappend = UnionSchema -> UnionSchema -> UnionSchema
forall a. Semigroup a => a -> a -> a
(<>)

{-| 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
    ArbitraryJSON <> :: Schema -> Schema -> Schema
<> _ = Schema
ArbitraryJSON
    _ <> ArbitraryJSON = Schema
ArbitraryJSON

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

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

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

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

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

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

    mappend :: Schema -> Schema -> Schema
mappend = Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
(<>)

-- | Convert a `Schema` to the corresponding Dhall type
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType Bool = Expr s a
forall s a. Expr s a
D.Bool
schemaToDhallType Natural = Expr s a
forall s a. Expr s a
D.Natural
schemaToDhallType Integer = Expr s a
forall s a. Expr s a
D.Integer
schemaToDhallType Double = Expr s a
forall s a. Expr s a
D.Double
schemaToDhallType Text = Expr s a
forall s a. Expr s a
D.Text
schemaToDhallType (List a :: Schema
a) = Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List (Schema -> Expr s a
forall s a. Schema -> Expr s a
schemaToDhallType Schema
a)
schemaToDhallType (Optional a :: Schema
a) = Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.Optional (Schema -> Expr s a
forall s a. Schema -> Expr s a
schemaToDhallType Schema
a)
schemaToDhallType (Record r :: RecordSchema
r) = RecordSchema -> Expr s a
forall s a. RecordSchema -> Expr s a
recordSchemaToDhallType RecordSchema
r
schemaToDhallType (Union u :: UnionSchema
u) = UnionSchema -> Expr s a
forall s a. UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema
u
schemaToDhallType ArbitraryJSON =
    Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type)
        (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_"
            (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record
                [ ("array" , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List (Int -> Expr s a
forall s a. Int -> Expr s a
V 0)) (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                , ("bool"  , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Bool (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                , ("double", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Double (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                , ("integer", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Integer (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                , ("null"  , Int -> Expr s a
forall s a. Int -> Expr s a
V 0)
                , ("object", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record [ ("mapKey", Expr s a
forall s a. Expr s a
D.Text), ("mapValue", Int -> Expr s a
forall s a. Int -> Expr s a
V 0)])) (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                , ("string", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Text (Int -> Expr s a
forall s a. Int -> Expr s a
V 1))
                ]
            )
            (Int -> Expr s a
forall s a. Int -> Expr s a
V 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 A
>>> import qualified Data.HashMap.Strict as HM

>>> s = D.Record (Map.fromList [("foo", D.Integer)])
>>> v = A.Object (HM.fromList [("foo", A.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 {..}) expressionType :: ExprX
expressionType =
    (ExprX -> ExprX)
-> Either CompileError ExprX -> Either CompileError ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASetter ExprX ExprX ExprX ExprX
-> (ExprX -> Maybe ExprX) -> ExprX -> ExprX
forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
Optics.rewriteOf ASetter ExprX ExprX ExprX ExprX
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
D.subExpressions ExprX -> Maybe ExprX
forall s a. Expr s a -> Maybe (Expr s a)
Lint.useToMap) (Either CompileError ExprX -> Either CompileError ExprX)
-> (Value -> Either CompileError ExprX)
-> Value
-> Either CompileError ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprX -> Value -> Either CompileError ExprX
loop (ExprX -> ExprX
forall s a. Expr s a -> Expr s a
D.alphaNormalize (ExprX -> ExprX
forall a s t. Eq a => Expr s a -> Expr t a
D.normalize ExprX
expressionType))
  where
    -- any ~> Union
    loop :: ExprX -> Value -> Either CompileError ExprX
loop t :: ExprX
t@(D.Union tm :: Map Text (Maybe ExprX)
tm) v :: Value
v = do
      let f :: Text -> Maybe ExprX -> Either CompileError ExprX
f key :: Text
key maybeType :: Maybe ExprX
maybeType =
            case Maybe ExprX
maybeType of
              Just _type :: ExprX
_type -> do
                ExprX
expression <- ExprX -> Value -> Either CompileError ExprX
loop ExprX
_type Value
v

                ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
D.App (ExprX -> Text -> ExprX
forall s a. Expr s a -> Text -> Expr s a
D.Field ExprX
t Text
key) ExprX
expression)

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

      case (UnionConv
unions, [Either CompileError ExprX] -> [ExprX]
forall a b. [Either a b] -> [b]
rights (Map Text (Either CompileError ExprX) -> [Either CompileError ExprX]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Text -> Maybe ExprX -> Either CompileError ExprX)
-> Map Text (Maybe ExprX) -> Map Text (Either CompileError ExprX)
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
        (UNone  , _         ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> CompileError
ContainsUnion ExprX
t)
        (UStrict, xs :: [ExprX]
xs@(_:_:_)) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> [ExprX] -> CompileError
UndecidableUnion ExprX
t Value
v [ExprX]
xs)
        (_      , [ ]       ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
Mismatch ExprX
t Value
v)
        (UFirst , x :: ExprX
x:_       ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right ExprX
x
        (UStrict, [x :: Item [ExprX]
x]       ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right ExprX
Item [ExprX]
x

    -- object ~> Record
    loop (D.Record r :: Map Text ExprX
r) v :: Value
v@(A.Object o :: Object
o)
        | [Text]
extraKeys <- Object -> [Text]
forall k v. HashMap k v -> [k]
HM.keys Object
o [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Map Text ExprX -> [Text]
forall k v. Map k v -> [k]
Map.keys Map Text ExprX
r
        , Bool
strictRecs Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
extraKeys)
        = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left ([Text] -> ExprX -> Value -> CompileError
UnhandledKeys [Text]
extraKeys (Map Text ExprX -> ExprX
forall s a. Map Text (Expr s a) -> Expr s a
D.Record Map Text ExprX
r) Value
v)
        | Bool
otherwise
        = let f :: Text -> ExprX -> Either CompileError ExprX
              f :: Text -> ExprX -> Either CompileError ExprX
f k :: Text
k t :: ExprX
t | Just value :: Value
value <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k Object
o
                    = ExprX -> Value -> Either CompileError ExprX
loop ExprX
t Value
value
                    | App D.Optional t' :: ExprX
t' <- ExprX
t
                    = ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
App ExprX
forall s a. Expr s a
D.None ExprX
t')
                    | App D.List _ <- ExprX
t
                    , Bool
omissibleLists
                    = ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (Maybe ExprX -> Seq ExprX -> ExprX
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit (ExprX -> Maybe ExprX
forall a. a -> Maybe a
Just ExprX
t) [])
                    | Bool
otherwise
                    = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (Text -> ExprX -> Value -> CompileError
MissingKey Text
k ExprX
t Value
v)
           in Map Text ExprX -> ExprX
forall s a. Map Text (Expr s a) -> Expr s a
D.RecordLit (Map Text ExprX -> ExprX)
-> Either CompileError (Map Text ExprX)
-> Either CompileError ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ExprX -> Either CompileError ExprX)
-> Map Text ExprX -> Either CompileError (Map Text ExprX)
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 Map Text ExprX
r

    -- key-value list ~> Record
    loop t :: ExprX
t@(D.Record _) v :: Value
v@(A.Array a :: Array
a)
        | Bool -> Bool
not Bool
noKeyValArr
        , [Value]
os :: [Value] <- Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a
        , Just kvs :: [(Text, Value)]
kvs <- (Value -> Maybe (Text, Value)) -> [Value] -> Maybe [(Text, Value)]
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
        = ExprX -> Value -> Either CompileError ExprX
loop ExprX
t (Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, Value)]
kvs)
        | Bool
noKeyValArr
        = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
NoKeyValArray ExprX
t Value
v)
        | Bool
otherwise
        = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
Mismatch ExprX
t Value
v)

    -- object ~> List (key, value)
    loop t :: ExprX
t@(App D.List (D.Record r :: Map Text ExprX
r)) v :: Value
v@(A.Object o :: Object
o)
        | Bool -> Bool
not Bool
noKeyValMap
        , ["mapKey", "mapValue"] [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text ExprX -> [Text]
forall k v. Map k v -> [k]
Map.keys Map Text ExprX
r
        , Just mapKey :: ExprX
mapKey   <- Text -> Map Text ExprX -> Maybe ExprX
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup "mapKey" Map Text ExprX
r
        , Just mapValue :: ExprX
mapValue <- Text -> Map Text ExprX -> Maybe ExprX
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup "mapValue" Map Text ExprX
r
        = do
          HashMap Text ExprX
keyExprMap <- (Value -> Either CompileError ExprX)
-> Object -> Either CompileError (HashMap Text ExprX)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ExprX -> Value -> Either CompileError ExprX
loop ExprX
mapValue) Object
o

          Text -> ExprX
toKey <- do
              case ExprX
mapKey of
                  D.Text    -> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall (m :: * -> *) a. Monad m => a -> m a
return (\key :: Text
key -> Chunks Src X -> ExprX
forall s a. Chunks s a -> Expr s a
D.TextLit ([(Text, ExprX)] -> Text -> Chunks Src X
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
key))
                  D.Union _ -> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall (m :: * -> *) a. Monad m => a -> m a
return (\key :: Text
key -> ExprX -> Text -> ExprX
forall s a. Expr s a -> Text -> Expr s a
D.Field ExprX
mapKey Text
key)
                  _         -> CompileError -> Either CompileError (Text -> ExprX)
forall a b. a -> Either a b
Left (ExprX -> Value -> CompileError
Mismatch ExprX
t Value
v)

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

          let records :: Seq ExprX
records = (((Text, ExprX) -> ExprX) -> Seq (Text, ExprX) -> Seq ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, ExprX) -> ExprX
f (Seq (Text, ExprX) -> Seq ExprX)
-> (HashMap Text ExprX -> Seq (Text, ExprX))
-> HashMap Text ExprX
-> Seq ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, ExprX)] -> Seq (Text, ExprX)
forall a. [a] -> Seq a
Seq.fromList ([(Text, ExprX)] -> Seq (Text, ExprX))
-> (HashMap Text ExprX -> [(Text, ExprX)])
-> HashMap Text ExprX
-> Seq (Text, ExprX)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text ExprX -> [(Text, ExprX)]
forall k v. HashMap k v -> [(k, v)]
HM.toList) HashMap Text ExprX
keyExprMap

          let typeAnn :: Maybe ExprX
typeAnn = if Object -> Bool
forall k v. HashMap k v -> Bool
HM.null Object
o then ExprX -> Maybe ExprX
forall a. a -> Maybe a
Just ExprX
t else Maybe ExprX
forall a. Maybe a
Nothing

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

    -- array ~> List
    loop (App D.List t :: ExprX
t) (A.Array a :: Array
a)
        = let f :: [ExprX] -> ExprX
              f :: [ExprX] -> ExprX
f es :: [ExprX]
es = Maybe ExprX -> Seq ExprX -> ExprX
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
D.ListLit
                       (if [ExprX] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExprX]
es then ExprX -> Maybe ExprX
forall a. a -> Maybe a
Just (ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
App ExprX
forall s a. Expr s a
D.List ExprX
t) else Maybe ExprX
forall a. Maybe a
Nothing)
                       ([ExprX] -> Seq ExprX
forall a. [a] -> Seq a
Seq.fromList [ExprX]
es)
           in [ExprX] -> ExprX
f ([ExprX] -> ExprX)
-> Either CompileError [ExprX] -> Either CompileError ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either CompileError ExprX)
-> [Value] -> Either CompileError [ExprX]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ExprX -> Value -> Either CompileError ExprX
loop ExprX
t) (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a)

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

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

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

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

    -- string ~> Text
    loop D.Text (A.String t :: Text
t)
        = ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (Chunks Src X -> ExprX
forall s a. Chunks s a -> Expr s a
D.TextLit ([(Text, ExprX)] -> Text -> Chunks Src X
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
t))

    -- bool ~> Bool
    loop D.Bool (A.Bool t :: Bool
t)
        = ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (Bool -> ExprX
forall s a. Bool -> Expr s a
D.BoolLit Bool
t)

    -- null ~> Optional
    loop (App D.Optional expr :: ExprX
expr) A.Null
        = ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
App ExprX
forall s a. Expr s a
D.None ExprX
expr

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

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

                      elements :: Seq (Expr s a)
elements =
                          [Expr s a] -> Seq (Expr s a)
forall a. [a] -> Seq a
Seq.fromList
                              (((Text, Value) -> Expr s a) -> [(Text, Value)] -> [Expr s a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> Expr s a
inner
                                  (((Text, Value) -> (Text, Value) -> Ordering)
-> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy
                                      (((Text, Value) -> Text)
-> (Text, Value) -> (Text, Value) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing (Text, Value) -> Text
forall a b. (a, b) -> a
fst)
                                      (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
o)
                                  )
                              )

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

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

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

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

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

          let result :: Expr s a
result =
                Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Lam "JSON" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type)
                    (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Lam "json"
                        (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record
                            [ ("array" , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List "JSON") "JSON")
                            , ("bool"  , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Bool "JSON")
                            , ("null"  , "JSON")
                            , ("number", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Double "JSON")
                            , ("object", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record [ ("mapKey", Expr s a
forall s a. Expr s a
D.Text), ("mapValue", "JSON")])) "JSON")
                            , ("string", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Text "JSON")
                            ]
                        )
                        (Value -> Expr s a
forall s a. Value -> Expr s a
outer Value
value)
                    )

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

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

                      elements :: Seq (Expr s a)
elements =
                          [Expr s a] -> Seq (Expr s a)
forall a. [a] -> Seq a
Seq.fromList
                              (((Text, Value) -> Expr s a) -> [(Text, Value)] -> [Expr s a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> Expr s a
inner
                                  (((Text, Value) -> (Text, Value) -> Ordering)
-> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy
                                      (((Text, Value) -> Text)
-> (Text, Value) -> (Text, Value) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing (Text, Value) -> Text
forall a b. (a, b) -> a
fst)
                                      (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
o)
                                  )
                              )

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

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

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

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

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

          let result :: Expr s a
result =
                Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Lam "JSON" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type)
                    (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Lam "json"
                        (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record
                            [ ("array" , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List "JSON") "JSON")
                            , ("bool"  , Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Bool "JSON")
                            , ("double", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Double "JSON")
                            , ("integer", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Integer "JSON")
                            , ("null"  , "JSON")
                            , ("object", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
D.App Expr s a
forall s a. Expr s a
D.List (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
D.Record [ ("mapKey", Expr s a
forall s a. Expr s a
D.Text), ("mapValue", "JSON")])) "JSON")
                            , ("string", Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
D.Pi "_" Expr s a
forall s a. Expr s a
D.Text "JSON")
                            ]
                        )
                        (Value -> Expr s a
forall s a. Value -> Expr s a
outer Value
value)
                    )

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

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


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

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

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

showJSON :: Value -> String
showJSON :: Value -> String
showJSON value :: Value
value = ByteString -> String
BSL8.unpack (Value -> ByteString
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
  -- record specific
  | MissingKey     Text  ExprX Value
  | UnhandledKeys [Text] ExprX Value
  | 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 "JSON" Value -> String
showJSON

instance Exception CompileError

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

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

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

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

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

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

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

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

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