{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Dhall.JSONToDhall (
parseConversion
, Conversion(..)
, defaultConversion
, resolveSchemaExpr
, typeCheckSchemaExpr
, dhallFromJSON
, Schema(..)
, RecordSchema(..)
, UnionSchema(..)
, inferSchema
, schemaToDhallType
, CompileError(..)
, showCompileError
) where
import Control.Applicative ((<|>))
import Control.Exception (Exception, throwIO)
import Control.Monad.Catch (MonadCatch, throwM)
import Data.Aeson (Value)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Either (rights)
import Data.Foldable (toList)
import Data.List ((\\))
import Data.Monoid (Any (..))
import Data.Scientific (floatingOrInteger, toRealFloat)
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App))
import Dhall.JSON.Util (pattern FA, pattern V)
import Dhall.Parser (Src)
import Options.Applicative (Parser)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map
import qualified Data.Map.Merge.Lazy as Data.Map.Merge
import qualified Data.Ord as Ord
import qualified Data.Sequence as Seq
import qualified Data.String
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Dhall.Core as D
import qualified Dhall.Import
import qualified Dhall.Lint as Lint
import qualified Dhall.Map as Map
import qualified Dhall.Optics as Optics
import qualified Dhall.Parser
import qualified Dhall.TypeCheck as D
import qualified Options.Applicative as O
parseConversion :: Parser Conversion
parseConversion = Conversion <$> parseStrict
<*> parseKVArr
<*> parseKVMap
<*> parseUnion
<*> parseOmissibleLists
where
parseStrict =
O.flag' True
( O.long "records-strict"
<> O.help "Fail if any JSON fields are missing from the expected Dhall type"
)
<|> O.flag' False
( O.long "records-loose"
<> O.help "Tolerate JSON fields not present within the expected Dhall type"
)
<|> pure True
parseKVArr = O.switch
( O.long "no-keyval-arrays"
<> O.help "Disable conversion of key-value arrays to records"
)
parseKVMap = O.switch
( O.long "no-keyval-maps"
<> O.help "Disable conversion of homogeneous map objects to association lists"
)
parseOmissibleLists = O.switch
( O.long "omissible-lists"
<> O.help "Tolerate missing list values, they are assumed empty"
)
parseUnion :: Parser UnionConv
parseUnion =
uFirst
<|> uNone
<|> uStrict
<|> pure UFirst
where
uFirst = O.flag' UFirst
( O.long "unions-first"
<> 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 = O.flag' UNone
( O.long "unions-none"
<> O.help "Unions not allowed"
)
uStrict = O.flag' UStrict
( O.long "unions-strict"
<> O.help "Error if more than one union values match the type (and parse successfully)"
)
data Conversion = Conversion
{ strictRecs :: Bool
, noKeyValArr :: Bool
, noKeyValMap :: Bool
, unions :: UnionConv
, omissibleLists :: Bool
} deriving Show
data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
defaultConversion :: Conversion
defaultConversion = Conversion
{ strictRecs = False
, noKeyValArr = False
, noKeyValMap = False
, unions = UFirst
, omissibleLists = False
}
type ExprX = Expr Src Void
resolveSchemaExpr :: Text
-> IO ExprX
resolveSchemaExpr code = do
parsedExpression <-
case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of
Left err -> throwIO err
Right parsedExpression -> return parsedExpression
Dhall.Import.load parsedExpression
typeCheckSchemaExpr :: (Exception e, MonadCatch m)
=> (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr compileException expr =
case D.typeOf expr of
Left err -> throwM . compileException $ TypeError err
Right t -> case t of
D.Const D.Type -> return expr
_ -> throwM . compileException $ BadDhallType t expr
keyValMay :: Value -> Maybe (Text, Value)
keyValMay (Aeson.Object o) = do
Aeson.String k <- HM.lookup "key" o
v <- HM.lookup "value" o
return (k, v)
keyValMay _ = Nothing
inferSchema :: Value -> Schema
inferSchema (Aeson.Object m) =
let convertMap = Data.Map.fromList . HM.toList
in (Record . RecordSchema . convertMap) (fmap inferSchema m)
inferSchema (Aeson.Array xs) =
List (Foldable.foldMap inferSchema xs)
inferSchema (Aeson.String _) =
Text
inferSchema (Aeson.Number n) =
case floatingOrInteger n of
Left (_ :: Double) -> Double
Right (integer :: Integer)
| 0 <= integer -> Natural
| otherwise -> Integer
inferSchema (Aeson.Bool _) =
Bool
inferSchema Aeson.Null =
Optional mempty
newtype RecordSchema =
RecordSchema { getRecordSchema :: Data.Map.Map Text Schema }
instance Semigroup RecordSchema where
RecordSchema l <> RecordSchema r = RecordSchema m
where
onMissing _ s = Just (s <> Optional mempty)
m = Data.Map.Merge.merge
(Data.Map.Merge.mapMaybeMissing onMissing)
(Data.Map.Merge.mapMaybeMissing onMissing)
(Data.Map.Merge.zipWithMatched (\_ -> (<>)))
l
r
recordSchemaToDhallType :: RecordSchema -> Expr s a
recordSchemaToDhallType (RecordSchema m) =
D.Record (Map.fromList (Data.Map.toList (fmap (D.makeRecordField . schemaToDhallType) m)))
data UnionNumber
= UnionAbsent
| UnionNatural
| UnionInteger
| UnionDouble
deriving (Bounded, Eq, Ord)
instance Semigroup UnionNumber where
(<>) = max
instance Monoid UnionNumber where
mempty = minBound
unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]
unionNumberToAlternatives UnionAbsent = []
unionNumberToAlternatives UnionNatural = [ ("Natural", Just D.Natural) ]
unionNumberToAlternatives UnionInteger = [ ("Integer", Just D.Integer) ]
unionNumberToAlternatives UnionDouble = [ ("Double" , Just D.Double ) ]
data UnionSchema = UnionSchema
{ bool :: Any
, number :: UnionNumber
, text :: Any
} deriving (Eq)
unionSchemaToDhallType :: UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema{..} = D.Union (Map.fromList alternatives)
where
alternatives =
(if getAny bool then [ ("Bool", Just D.Bool) ] else [])
<> unionNumberToAlternatives number
<> (if getAny text then [ ("Text", Just D.Text) ] else [])
instance Semigroup UnionSchema where
UnionSchema boolL numberL textL <> UnionSchema boolR numberR textR =
UnionSchema{..}
where
bool = boolL <> boolR
number = numberL <> numberR
text = textL <> textR
instance Monoid UnionSchema where
mempty = UnionSchema{..}
where
bool = mempty
number = mempty
text = mempty
data Schema
= Bool
| Natural
| Integer
| Double
| Text
| List Schema
| Optional Schema
| Record RecordSchema
| Union UnionSchema
| ArbitraryJSON
instance Semigroup Schema where
ArbitraryJSON <> _ = ArbitraryJSON
_ <> ArbitraryJSON = ArbitraryJSON
Bool <> Bool = Bool
Text <> Text = Text
Natural <> Natural = Natural
Integer <> Integer = Integer
Double <> Double = Double
Record l <> Record r = Record (l <> r)
List l <> List r = List (l <> r)
Union l <> Union r = Union (l <> r)
Optional l <> Optional r = Optional (l <> r)
Natural <> Integer = Integer
Integer <> Natural = Integer
Natural <> Double = Double
Integer <> Double = Double
Double <> Natural = Double
Double <> Integer = Double
Bool <> Natural = Union mempty{ bool = Any True, number = UnionNatural }
Bool <> Integer = Union mempty{ bool = Any True, number = UnionInteger }
Bool <> Double = Union mempty{ bool = Any True, number = UnionDouble }
Bool <> Text = Union mempty{ bool = Any True, text = Any True }
Natural <> Bool = Union mempty{ bool = Any True, number = UnionNatural }
Natural <> Text = Union mempty{ number = UnionNatural, text = Any True }
Integer <> Bool = Union mempty{ bool = Any True, number = UnionInteger }
Integer <> Text = Union mempty{ number = UnionInteger, text = Any True }
Double <> Bool = Union mempty{ bool = Any True, number = UnionDouble }
Double <> Text = Union mempty{ number = UnionDouble, text = Any True }
Text <> Bool = Union mempty{ bool = Any True, text = Any True }
Text <> Natural = Union mempty{ number = UnionNatural, text = Any True }
Text <> Integer = Union mempty{ number = UnionInteger, text = Any True }
Text <> Double = Union mempty{ number = UnionDouble, text = Any True }
Union l <> r | l == mempty = r
l <> Union r | r == mempty = l
Bool <> Union r = Union (mempty{ bool = Any True } <> r)
Natural <> Union r = Union (mempty{ number = UnionNatural } <> r)
Integer <> Union r = Union (mempty{ number = UnionInteger } <> r)
Double <> Union r = Union (mempty{ number = UnionDouble} <> r)
Text <> Union r = Union (mempty{ text = Any True } <> r)
Union l <> Bool = Union (l <> mempty{ bool = Any True })
Union l <> Natural = Union (l <> mempty{ number = UnionNatural })
Union l <> Integer = Union (l <> mempty{ number = UnionInteger })
Union l <> Double = Union (l <> mempty{ number = UnionDouble })
Union l <> Text = Union (l <> mempty{ text = Any True })
Optional l <> r = Optional (l <> r)
l <> Optional r = Optional (l <> r)
List _ <> _ = ArbitraryJSON
_ <> List _ = ArbitraryJSON
Record _ <> _ = ArbitraryJSON
_ <> Record _ = ArbitraryJSON
instance Monoid Schema where
mempty = Union mempty
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType Bool = D.Bool
schemaToDhallType Natural = D.Natural
schemaToDhallType Integer = D.Integer
schemaToDhallType Double = D.Double
schemaToDhallType Text = D.Text
schemaToDhallType (List a) = D.App D.List (schemaToDhallType a)
schemaToDhallType (Optional a) = D.App D.Optional (schemaToDhallType a)
schemaToDhallType (Record r) = recordSchemaToDhallType r
schemaToDhallType (Union u) = unionSchemaToDhallType u
schemaToDhallType ArbitraryJSON =
D.Pi "_" (D.Const D.Type)
(D.Pi "_"
(D.Record
[ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List (V 0)) (V 1))
, ("bool" , D.makeRecordField $ D.Pi "_" D.Bool (V 1))
, ("double", D.makeRecordField $ D.Pi "_" D.Double (V 1))
, ("integer", D.makeRecordField $ D.Pi "_" D.Integer (V 1))
, ("null" , D.makeRecordField $ V 0)
, ("object", D.makeRecordField $
D.Pi "_" (D.App D.List (D.Record
[ ("mapKey", D.makeRecordField D.Text)
, ("mapValue", D.makeRecordField $ V 0)
])) (V 1))
, ("string", D.makeRecordField $ D.Pi "_" D.Text (V 1))
]
)
(V 1)
)
dhallFromJSON
:: Conversion -> ExprX -> Value -> Either CompileError ExprX
dhallFromJSON (Conversion {..}) expressionType =
fmap (Optics.rewriteOf D.subExpressions Lint.useToMap) . loop [] (D.alphaNormalize (D.normalize expressionType))
where
loop :: Aeson.Types.JSONPath -> ExprX -> Aeson.Value -> Either CompileError ExprX
loop jsonPath t@(D.Union tm) v = do
let f key maybeType =
case maybeType of
Just _type -> do
expression <- loop jsonPath _type v
return (D.App (D.Field t $ FA key) expression)
Nothing ->
case v of
Aeson.String text | key == text ->
return (D.Field t $ FA key)
_ ->
Left (Mismatch t v jsonPath)
case (unions, rights (toList (Map.mapWithKey f tm))) of
(UNone , _ ) -> Left (ContainsUnion t)
(UStrict, xs@(_:_:_)) -> Left (UndecidableUnion t v xs)
(_ , [ ] ) -> Left (Mismatch t v jsonPath)
(UFirst , x:_ ) -> Right x
(UStrict, [x] ) -> Right x
loop jsonPath (D.Record r) v@(Aeson.Object o)
| extraKeys <- HM.keys o \\ Map.keys r
, strictRecs && not (null extraKeys)
= Left (UnhandledKeys extraKeys (D.Record r) v jsonPath)
| otherwise
= let f :: Text -> ExprX -> Either CompileError ExprX
f k t | Just value <- HM.lookup k o
= loop (Aeson.Types.Key k : jsonPath) t value
| App D.Optional t' <- t
= Right (App D.None t')
| App D.List _ <- t
, omissibleLists
= Right (D.ListLit (Just t) [])
| otherwise
= Left (MissingKey k t v jsonPath)
in D.RecordLit . fmap D.makeRecordField <$> Map.traverseWithKey f (D.recordFieldValue <$> r)
loop jsonPath t@(D.Record _) v@(Aeson.Array a)
| not noKeyValArr
, os :: [Value] <- toList a
, Just kvs <- traverse keyValMay os
= loop jsonPath t (Aeson.Object $ HM.fromList kvs)
| noKeyValArr
= Left (NoKeyValArray t v)
| otherwise
= Left (Mismatch t v jsonPath)
loop jsonPath t@(App D.List (D.Record r)) v@(Aeson.Object o)
| not noKeyValMap
, ["mapKey", "mapValue"] == Map.keys r
, Just mapKey <- D.recordFieldValue <$> Map.lookup "mapKey" r
, Just mapValue <- D.recordFieldValue <$> Map.lookup "mapValue" r
= do
keyExprMap <- HM.traverseWithKey (\k child -> loop (Aeson.Types.Key k : jsonPath) mapValue child) o
toKey <-
case mapKey of
D.Text -> return $ D.TextLit . Chunks []
D.Union _ -> return $ D.Field mapKey . FA
_ -> Left (Mismatch t v jsonPath)
let f :: (Text, ExprX) -> ExprX
f (key, val) = D.RecordLit $ D.makeRecordField <$> Map.fromList
[ ("mapKey" , toKey key)
, ("mapValue", val)
]
let records = (fmap f . Seq.fromList . HM.toList) keyExprMap
let typeAnn = if HM.null o then Just t else Nothing
return (D.ListLit typeAnn records)
| noKeyValMap
= Left (NoKeyValMap t v)
| otherwise
= Left (Mismatch t v jsonPath)
loop jsonPath (App D.List t) (Aeson.Array a)
= let f :: [ExprX] -> ExprX
f es = D.ListLit
(if null es then Just (App D.List t) else Nothing)
(Seq.fromList es)
in f <$> traverse (\(idx, val) -> loop (Aeson.Types.Index idx : jsonPath) t val) (zip [0..] $ toList a)
loop jsonPath t@(App D.List _) Aeson.Null
= if omissibleLists
then Right (D.ListLit (Just t) [])
else Left (Mismatch t Aeson.Null jsonPath)
loop jsonPath D.Integer (Aeson.Number x)
| Right n <- floatingOrInteger x :: Either Double Integer
= Right (D.IntegerLit n)
| otherwise
= Left (Mismatch D.Integer (Aeson.Number x) jsonPath)
loop jsonPath D.Natural (Aeson.Number x)
| Right n <- floatingOrInteger x :: Either Double Integer
, n >= 0
= Right (D.NaturalLit (fromInteger n))
| otherwise
= Left (Mismatch D.Natural (Aeson.Number x) jsonPath)
loop _ D.Double (Aeson.Number x)
= Right (D.DoubleLit $ DhallDouble $ toRealFloat x)
loop _ D.Text (Aeson.String t)
= Right (D.TextLit (Chunks [] t))
loop _ D.Bool (Aeson.Bool t)
= Right (D.BoolLit t)
loop _ (App D.Optional expr) Aeson.Null
= Right $ App D.None expr
loop jsonPath (App D.Optional expr) value
= D.Some <$> loop jsonPath expr value
loop
_
(D.Pi _ (D.Const D.Type)
(D.Pi _
(D.Record
[ ("array" , D.recordFieldValue -> D.Pi _ (D.App D.List (V 0)) (V 1))
, ("bool" , D.recordFieldValue -> D.Pi _ D.Bool (V 1))
, ("null" , D.recordFieldValue -> V 0)
, ("number", D.recordFieldValue -> D.Pi _ D.Double (V 1))
, ("object", D.recordFieldValue ->
D.Pi _ (D.App D.List (D.Record
[ ("mapKey", D.recordFieldValue -> D.Text)
, ("mapValue", D.recordFieldValue -> V 0)
])) (V 1))
, ("string", D.recordFieldValue -> D.Pi _ D.Text (V 1))
]
)
(V 1)
)
)
value = do
let outer (Aeson.Object o) =
let inner (key, val) =
D.RecordLit
[ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))
, ("mapValue", D.makeRecordField $ outer val )
]
elements =
Seq.fromList
(fmap inner
(List.sortBy
(Ord.comparing fst)
(HM.toList o)
)
)
elementType
| null elements =
Just (D.App D.List (D.Record
[ ("mapKey", D.makeRecordField D.Text)
, ("mapValue", D.makeRecordField "JSON")
]))
| otherwise =
Nothing
keyValues = D.ListLit elementType elements
in D.App (D.Field "json" $ FA "object") keyValues
outer (Aeson.Array a) =
let elements = Seq.fromList (fmap outer (Vector.toList a))
elementType
| null elements = Just (D.App D.List "JSON")
| otherwise = Nothing
in D.App (D.Field "json" $ FA "array") (D.ListLit elementType elements)
outer (Aeson.String s) =
D.App (D.Field "json" $ FA "string") (D.TextLit (D.Chunks [] s))
outer (Aeson.Number n) =
D.App (D.Field "json" $ FA "number") (D.DoubleLit (DhallDouble (toRealFloat n)))
outer (Aeson.Bool b) =
D.App (D.Field "json" $ FA "bool") (D.BoolLit b)
outer Aeson.Null =
D.Field "json" $ FA "null"
let result =
D.Lam (D.makeFunctionBinding "JSON" (D.Const D.Type))
(D.Lam (D.makeFunctionBinding "json"
(D.Record
[ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON")
, ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON")
, ("null" , D.makeRecordField "JSON")
, ("number", D.makeRecordField $ D.Pi "_" D.Double "JSON")
, ("object", D.makeRecordField $
D.Pi "_" (D.App D.List (D.Record
[ ("mapKey", D.makeRecordField D.Text)
, ("mapValue", D.makeRecordField "JSON")
])) "JSON")
, ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON")
]
))
(outer value)
)
return result
loop
_
(D.Pi _ (D.Const D.Type)
(D.Pi _
(D.Record
[ ("array" , D.recordFieldValue -> D.Pi _ (D.App D.List (V 0)) (V 1))
, ("bool" , D.recordFieldValue -> D.Pi _ D.Bool (V 1))
, ("double", D.recordFieldValue -> D.Pi _ D.Double (V 1))
, ("integer", D.recordFieldValue -> D.Pi _ D.Integer (V 1))
, ("null" , D.recordFieldValue -> V 0)
, ("object", D.recordFieldValue ->
D.Pi _ (D.App D.List (D.Record
[ ("mapKey", D.recordFieldValue -> D.Text)
, ("mapValue", D.recordFieldValue -> V 0)
])) (V 1))
, ("string", D.recordFieldValue -> D.Pi _ D.Text (V 1))
]
)
(V 1)
)
)
value = do
let outer (Aeson.Object o) =
let inner (key, val) =
D.RecordLit
[ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))
, ("mapValue", D.makeRecordField $ outer val )
]
elements =
Seq.fromList
(fmap inner
(List.sortBy
(Ord.comparing fst)
(HM.toList o)
)
)
elementType
| null elements =
Just (D.App D.List (D.Record
[ ("mapKey", D.makeRecordField D.Text)
, ("mapValue", D.makeRecordField "JSON") ]))
| otherwise =
Nothing
keyValues = D.ListLit elementType elements
in D.App (D.Field "json" (FA "object")) keyValues
outer (Aeson.Array a) =
let elements = Seq.fromList (fmap outer (Vector.toList a))
elementType
| null elements = Just (D.App D.List "JSON")
| otherwise = Nothing
in D.App (D.Field "json" (FA "array")) (D.ListLit elementType elements)
outer (Aeson.String s) =
D.App (D.Field "json" (FA "string")) (D.TextLit (D.Chunks [] s))
outer (Aeson.Number n) =
case floatingOrInteger n of
Left floating -> D.App (D.Field "json" (FA "double")) (D.DoubleLit (DhallDouble floating))
Right integer -> D.App (D.Field "json" (FA "integer")) (D.IntegerLit integer)
outer (Aeson.Bool b) =
D.App (D.Field "json" (FA "bool")) (D.BoolLit b)
outer Aeson.Null =
D.Field "json" (FA "null")
let result =
D.Lam (D.makeFunctionBinding "JSON" (D.Const D.Type))
(D.Lam (D.makeFunctionBinding "json"
(D.Record
[ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON")
, ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON")
, ("double", D.makeRecordField $ D.Pi "_" D.Double "JSON")
, ("integer", D.makeRecordField $ D.Pi "_" D.Integer "JSON")
, ("null" , D.makeRecordField "JSON")
, ("object", D.makeRecordField $ D.Pi "_"
(D.App D.List (D.Record
[ ("mapKey", D.makeRecordField D.Text)
, ("mapValue", D.makeRecordField "JSON")])) "JSON")
, ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON")
]
))
(outer value)
)
return result
loop jsonPath expr value
= Left (Mismatch expr value jsonPath)
red, purple, green
:: (Semigroup a, Data.String.IsString a) => a -> a
red s = "\ESC[1;31m" <> s <> "\ESC[0m"
purple s = "\ESC[1;35m" <> s <> "\ESC[0m"
green s = "\ESC[0;32m" <> s <> "\ESC[0m"
showExpr :: ExprX -> String
showExpr dhall = Text.unpack (D.pretty dhall)
showJSON :: Value -> String
showJSON value = BSL8.unpack (encodePretty value)
data CompileError
= TypeError (D.TypeError Src Void)
| BadDhallType
ExprX
ExprX
| Mismatch
ExprX
Value
Aeson.Types.JSONPath
| MissingKey Text ExprX Value Aeson.Types.JSONPath
| UnhandledKeys [Text] ExprX Value Aeson.Types.JSONPath
| NoKeyValArray ExprX Value
| NoKeyValMap ExprX Value
| ContainsUnion ExprX
| UndecidableUnion ExprX Value [ExprX]
instance Show CompileError where
show = showCompileError "JSON" showJSON
instance Exception CompileError
showCompileError :: String -> (Value -> String) -> CompileError -> String
showCompileError format showValue = let prefix = red "\nError: "
in \case
TypeError e -> show e
BadDhallType t e -> prefix
<> "Schema expression is successfully parsed but has Dhall type:\n"
<> showExpr t <> "\nExpected Dhall type: Type"
<> "\nParsed expression: "
<> showExpr e <> "\n"
ContainsUnion e -> prefix
<> "Dhall type expression contains union type:\n"
<> showExpr e <> "\nwhile it is forbidden by option "
<> green "--unions-none\n"
UndecidableUnion e v xs -> prefix
<> "More than one union component type matches " <> format <> " value"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n\nPossible matches:\n\n"
<> Text.unpack (Text.intercalate sep $ D.pretty <$> xs)
where sep = red "\n--------\n" :: Text
Mismatch e v jsonPath -> prefix
<> showJsonPath jsonPath <> ": Dhall type expression and " <> format <> " value do not match:"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
MissingKey k e v jsonPath -> prefix
<> showJsonPath jsonPath <> ": Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n"
<> showExpr e
<> "\nis not present in " <> format <> " object:\n"
<> showValue v <> "\n"
UnhandledKeys ks e v jsonPath -> prefix
<> showJsonPath jsonPath <> ": Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks))
<> " present in the " <> format <> " object but not in the expected Dhall"
<> " record type. This is not allowed unless you enable the "
<> green "--records-loose" <> " flag:"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
NoKeyValArray e v -> prefix
<> "" <> format <> " (key-value) arrays cannot be converted to Dhall records under "
<> green "--no-keyval-arrays" <> " flag"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
NoKeyValMap e v -> prefix
<> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under "
<> green "--no-keyval-maps" <> " flag"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
showJsonPath :: Aeson.Types.JSONPath -> String
showJsonPath = Aeson.Types.formatPath . reverse