{-# 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 :: 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 String
"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 String
"Fail if any JSON 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 String
"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 String
"Tolerate JSON 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 String
"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 String
"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 String
"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 String
"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 String
"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 String
"Tolerate missing list values, they are assumed empty"
)
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
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 String
"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 String
"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 String
"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 String
"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 String
"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 String
"Error if more than one union values match the type (and parse successfully)"
)
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)
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
}
type ExprX = Expr Src Void
resolveSchemaExpr :: Text
-> IO ExprX
resolveSchemaExpr :: Text -> IO ExprX
resolveSchemaExpr Text
code = do
Expr Src Import
parsedExpression <-
case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText String
"\n\ESC[1;31mSCHEMA\ESC[0m" Text
code of
Left ParseError
err -> ParseError -> IO (Expr Src Import)
forall e a. Exception e => e -> IO a
throwIO ParseError
err
Right 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
typeCheckSchemaExpr :: (Exception e, MonadCatch m)
=> (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr :: (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr CompileError -> e
compileException 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
Left 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 ExprX
t -> case ExprX
t of
D.Const Const
D.Type -> ExprX -> m ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return ExprX
expr
ExprX
_ -> 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 (Aeson.Object Object
o) = do
Aeson.String Text
k <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"key" Object
o
Value
v <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"value" Object
o
(Text, Value) -> Maybe (Text, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Value
v)
keyValMay Value
_ = Maybe (Text, Value)
forall a. Maybe a
Nothing
inferSchema :: Value -> Schema
inferSchema :: Value -> Schema
inferSchema (Aeson.Object 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 (Aeson.Array 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 (Aeson.String Text
_) =
Schema
Text
inferSchema (Aeson.Number 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)
| Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
integer -> Schema
Natural
| Bool
otherwise -> Schema
Integer
inferSchema (Aeson.Bool Bool
_) =
Schema
Bool
inferSchema Value
Aeson.Null =
Schema -> Schema
Optional Schema
forall a. Monoid a => a
mempty
newtype RecordSchema =
RecordSchema { RecordSchema -> Map Text Schema
getRecordSchema :: Data.Map.Map Text Schema }
instance Semigroup RecordSchema where
RecordSchema Map Text Schema
l <> :: RecordSchema -> RecordSchema -> RecordSchema
<> RecordSchema Map Text Schema
r = Map Text Schema -> RecordSchema
RecordSchema Map Text Schema
m
where
onMissing :: p -> Schema -> Maybe Schema
onMissing p
_ 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 (\Text
_ -> 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 Map Text Schema
m) =
Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record ([(Text, RecordField s a)] -> Map Text (RecordField s a)
forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList (Map Text (RecordField s a) -> [(Text, RecordField s a)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList ((Schema -> RecordField s a)
-> Map Text Schema -> Map Text (RecordField s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a)
-> (Schema -> Expr s a) -> Schema -> RecordField s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Expr s a
forall s a. Schema -> Expr s a
schemaToDhallType) Map Text Schema
m)))
data UnionNumber
= UnionAbsent
| UnionNatural
| UnionInteger
| UnionDouble
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)
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
unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]
unionNumberToAlternatives :: UnionNumber -> [(Text, Maybe (Expr s a))]
unionNumberToAlternatives UnionNumber
UnionAbsent = []
unionNumberToAlternatives UnionNumber
UnionNatural = [ (Text
"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 UnionNumber
UnionInteger = [ (Text
"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 UnionNumber
UnionDouble = [ (Text
"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 ) ]
data UnionSchema = UnionSchema
{ UnionSchema -> Any
bool :: Any
, UnionSchema -> UnionNumber
number :: UnionNumber
, UnionSchema -> Any
text :: Any
} 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{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: UnionSchema -> Any
number :: UnionSchema -> UnionNumber
bool :: UnionSchema -> Any
..} = 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 [ (Text
"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
"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 [])
instance Semigroup UnionSchema where
UnionSchema Any
boolL UnionNumber
numberL Any
textL <> :: UnionSchema -> UnionSchema -> UnionSchema
<> UnionSchema Any
boolR UnionNumber
numberR Any
textR =
UnionSchema :: Any -> UnionNumber -> Any -> UnionSchema
UnionSchema{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: Any
number :: UnionNumber
bool :: Any
..}
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{Any
UnionNumber
text :: Any
number :: UnionNumber
bool :: Any
text :: Any
number :: UnionNumber
bool :: Any
..}
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
data Schema
= Bool
| Natural
| Integer
| Double
| Text
| List Schema
| Optional Schema
| Record RecordSchema
| Union UnionSchema
| ArbitraryJSON
instance Semigroup Schema where
Schema
ArbitraryJSON <> :: Schema -> Schema -> Schema
<> Schema
_ = Schema
ArbitraryJSON
Schema
_ <> Schema
ArbitraryJSON = Schema
ArbitraryJSON
Schema
Bool <> Schema
Bool = Schema
Bool
Schema
Text <> Schema
Text = Schema
Text
Schema
Natural <> Schema
Natural = Schema
Natural
Schema
Integer <> Schema
Integer = Schema
Integer
Schema
Double <> Schema
Double = Schema
Double
Record RecordSchema
l <> Record RecordSchema
r = RecordSchema -> Schema
Record (RecordSchema
l RecordSchema -> RecordSchema -> RecordSchema
forall a. Semigroup a => a -> a -> a
<> RecordSchema
r)
List Schema
l <> List Schema
r = Schema -> Schema
List (Schema
l Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
r)
Union UnionSchema
l <> Union UnionSchema
r = UnionSchema -> Schema
Union (UnionSchema
l UnionSchema -> UnionSchema -> UnionSchema
forall a. Semigroup a => a -> a -> a
<> UnionSchema
r)
Optional Schema
l <> Optional Schema
r = Schema -> Schema
Optional (Schema
l Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
r)
Schema
Natural <> Schema
Integer = Schema
Integer
Schema
Integer <> Schema
Natural = Schema
Integer
Schema
Natural <> Schema
Double = Schema
Double
Schema
Integer <> Schema
Double = Schema
Double
Schema
Double <> Schema
Natural = Schema
Double
Schema
Double <> Schema
Integer = Schema
Double
Schema
Bool <> Schema
Natural = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionNatural }
Schema
Bool <> Schema
Integer = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionInteger }
Schema
Bool <> Schema
Double = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionDouble }
Schema
Bool <> Schema
Text = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Natural <> Schema
Bool = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionNatural }
Schema
Natural <> Schema
Text = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Integer <> Schema
Bool = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionInteger }
Schema
Integer <> Schema
Text = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Double <> Schema
Bool = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, number :: UnionNumber
number = UnionNumber
UnionDouble }
Schema
Double <> Schema
Text = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Text <> Schema
Bool = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ bool :: Any
bool = Bool -> Any
Any Bool
True, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Text <> Schema
Natural = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionNatural, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Text <> Schema
Integer = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionInteger, text :: Any
text = Bool -> Any
Any Bool
True }
Schema
Text <> Schema
Double = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty{ number :: UnionNumber
number = UnionNumber
UnionDouble, text :: Any
text = Bool -> Any
Any Bool
True }
Union UnionSchema
l <> Schema
r | UnionSchema
l UnionSchema -> UnionSchema -> Bool
forall a. Eq a => a -> a -> Bool
== UnionSchema
forall a. Monoid a => a
mempty = Schema
r
Schema
l <> Union UnionSchema
r | UnionSchema
r UnionSchema -> UnionSchema -> Bool
forall a. Eq a => a -> a -> Bool
== UnionSchema
forall a. Monoid a => a
mempty = Schema
l
Schema
Bool <> Union 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)
Schema
Natural <> Union 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)
Schema
Integer <> Union 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)
Schema
Double <> Union 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)
Schema
Text <> Union 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 UnionSchema
l <> Schema
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 UnionSchema
l <> Schema
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 UnionSchema
l <> Schema
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 UnionSchema
l <> Schema
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 UnionSchema
l <> Schema
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 })
Optional Schema
l <> Schema
r = Schema -> Schema
Optional (Schema
l Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
r)
Schema
l <> Optional Schema
r = Schema -> Schema
Optional (Schema
l Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
r)
List Schema
_ <> Schema
_ = Schema
ArbitraryJSON
Schema
_ <> List Schema
_ = Schema
ArbitraryJSON
Record RecordSchema
_ <> Schema
_ = Schema
ArbitraryJSON
Schema
_ <> Record RecordSchema
_ = Schema
ArbitraryJSON
instance Monoid Schema where
mempty :: Schema
mempty = UnionSchema -> Schema
Union UnionSchema
forall a. Monoid a => a
mempty
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType Schema
Bool = Expr s a
forall s a. Expr s a
D.Bool
schemaToDhallType Schema
Natural = Expr s a
forall s a. Expr s a
D.Natural
schemaToDhallType Schema
Integer = Expr s a
forall s a. Expr s a
D.Integer
schemaToDhallType Schema
Double = Expr s a
forall s a. Expr s a
D.Double
schemaToDhallType Schema
Text = Expr s a
forall s a. Expr s a
D.Text
schemaToDhallType (List 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 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 RecordSchema
r) = RecordSchema -> Expr s a
forall s a. RecordSchema -> Expr s a
recordSchemaToDhallType RecordSchema
r
schemaToDhallType (Union UnionSchema
u) = UnionSchema -> Expr s a
forall s a. UnionSchema -> Expr s a
unionSchemaToDhallType UnionSchema
u
schemaToDhallType Schema
ArbitraryJSON =
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type)
(Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_"
(Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"array" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (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 Int
0)) (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
, (Text
"bool" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Bool (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
, (Text
"double", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Double (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
, (Text
"integer", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Integer (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
, (Text
"null" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Int -> Expr s a
forall s a. Int -> Expr s a
V Int
0)
, (Text
"object", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (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 (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"mapKey", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
forall s a. Expr s a
D.Text)
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Int -> Expr s a
forall s a. Int -> Expr s a
V Int
0)
])) (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
, (Text
"string", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Text (Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1))
]
)
(Int -> Expr s a
forall s a. Int -> Expr s a
V Int
1)
)
dhallFromJSON
:: Conversion -> ExprX -> Value -> Either CompileError ExprX
dhallFromJSON :: Conversion -> ExprX -> Value -> Either CompileError ExprX
dhallFromJSON (Conversion {Bool
UnionConv
omissibleLists :: Bool
unions :: UnionConv
noKeyValMap :: Bool
noKeyValArr :: Bool
strictRecs :: Bool
omissibleLists :: Conversion -> Bool
unions :: Conversion -> UnionConv
noKeyValMap :: Conversion -> Bool
noKeyValArr :: Conversion -> Bool
strictRecs :: Conversion -> Bool
..}) ExprX
expressionType =
(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
. JSONPath -> 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
loop :: Aeson.Types.JSONPath -> ExprX -> Aeson.Value -> Either CompileError ExprX
loop :: JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath t :: ExprX
t@(D.Union Map Text (Maybe ExprX)
tm) Value
v = do
let f :: Text -> Maybe ExprX -> Either CompileError ExprX
f Text
key Maybe ExprX
maybeType =
case Maybe ExprX
maybeType of
Just ExprX
_type -> do
ExprX
expression <- JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
_type Value
v
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 -> FieldSelection Src -> ExprX
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
t (FieldSelection Src -> ExprX) -> FieldSelection Src -> ExprX
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
FA Text
key) ExprX
expression)
Maybe ExprX
Nothing ->
case Value
v of
Aeson.String Text
text | Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
text ->
ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> FieldSelection Src -> ExprX
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
t (FieldSelection Src -> ExprX) -> FieldSelection Src -> ExprX
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
FA Text
key)
Value
_ ->
CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
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
(UnionConv
UNone , [ExprX]
_ ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> CompileError
ContainsUnion ExprX
t)
(UnionConv
UStrict, xs :: [ExprX]
xs@(ExprX
_:ExprX
_:[ExprX]
_)) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> [ExprX] -> CompileError
UndecidableUnion ExprX
t Value
v [ExprX]
xs)
(UnionConv
_ , [ ] ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
(UnionConv
UFirst , ExprX
x:[ExprX]
_ ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right ExprX
x
(UnionConv
UStrict, [Item [ExprX]
x] ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right Item [ExprX]
ExprX
x
loop JSONPath
jsonPath (D.Record Map Text (RecordField Src X)
r) v :: Value
v@(Aeson.Object 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 (RecordField Src X) -> [Text]
forall k v. Map k v -> [k]
Map.keys Map Text (RecordField Src X)
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 -> JSONPath -> CompileError
UnhandledKeys [Text]
extraKeys (Map Text (RecordField Src X) -> ExprX
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record Map Text (RecordField Src X)
r) Value
v JSONPath
jsonPath)
| Bool
otherwise
= let f :: Text -> ExprX -> Either CompileError ExprX
f :: Text -> ExprX -> Either CompileError ExprX
f Text
k ExprX
t | Just Value
value <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k Object
o
= JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Text -> JSONPathElement
Aeson.Types.Key Text
k JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
t Value
value
| App ExprX
D.Optional 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 ExprX
D.List ExprX
_ <- 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 -> JSONPath -> CompileError
MissingKey Text
k ExprX
t Value
v JSONPath
jsonPath)
in Map Text (RecordField Src X) -> ExprX
forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit (Map Text (RecordField Src X) -> ExprX)
-> (Map Text ExprX -> Map Text (RecordField Src X))
-> Map Text ExprX
-> ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExprX -> RecordField Src X)
-> Map Text ExprX -> Map Text (RecordField Src X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExprX -> RecordField Src X
forall s a. Expr s a -> RecordField s a
D.makeRecordField (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 (RecordField Src X -> ExprX
forall s a. RecordField s a -> Expr s a
D.recordFieldValue (RecordField Src X -> ExprX)
-> Map Text (RecordField Src X) -> Map Text ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Src X)
r)
loop JSONPath
jsonPath t :: ExprX
t@(D.Record Map Text (RecordField Src X)
_) v :: Value
v@(Aeson.Array Array
a)
| Bool -> Bool
not Bool
noKeyValArr
, [Value]
os :: [Value] <- Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a
, Just [(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
= JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
t (Object -> Value
Aeson.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 -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
loop JSONPath
jsonPath t :: ExprX
t@(App ExprX
D.List (D.Record Map Text (RecordField Src X)
r)) v :: Value
v@(Aeson.Object Object
o)
| Bool -> Bool
not Bool
noKeyValMap
, [Item [Text]
"mapKey", Item [Text]
"mapValue"] [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text (RecordField Src X) -> [Text]
forall k v. Map k v -> [k]
Map.keys Map Text (RecordField Src X)
r
, Just ExprX
mapKey <- RecordField Src X -> ExprX
forall s a. RecordField s a -> Expr s a
D.recordFieldValue (RecordField Src X -> ExprX)
-> Maybe (RecordField Src X) -> Maybe ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField Src X) -> Maybe (RecordField Src X)
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"mapKey" Map Text (RecordField Src X)
r
, Just ExprX
mapValue <- RecordField Src X -> ExprX
forall s a. RecordField s a -> Expr s a
D.recordFieldValue (RecordField Src X -> ExprX)
-> Maybe (RecordField Src X) -> Maybe ExprX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField Src X) -> Maybe (RecordField Src X)
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"mapValue" Map Text (RecordField Src X)
r
= do
HashMap Text ExprX
keyExprMap <- (Text -> Value -> Either CompileError ExprX)
-> Object -> Either CompileError (HashMap Text ExprX)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey (\Text
k Value
child -> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Text -> JSONPathElement
Aeson.Types.Key Text
k JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
mapValue Value
child) Object
o
Text -> ExprX
toKey <-
case ExprX
mapKey of
ExprX
D.Text -> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> ExprX) -> Either CompileError (Text -> ExprX))
-> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall a b. (a -> b) -> a -> b
$ Chunks Src X -> ExprX
forall s a. Chunks s a -> Expr s a
D.TextLit (Chunks Src X -> ExprX) -> (Text -> Chunks Src X) -> Text -> ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, ExprX)] -> Text -> Chunks Src X
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks []
D.Union Map Text (Maybe ExprX)
_ -> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> ExprX) -> Either CompileError (Text -> ExprX))
-> (Text -> ExprX) -> Either CompileError (Text -> ExprX)
forall a b. (a -> b) -> a -> b
$ ExprX -> FieldSelection Src -> ExprX
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field ExprX
mapKey (FieldSelection Src -> ExprX)
-> (Text -> FieldSelection Src) -> Text -> ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FieldSelection Src
forall s. Text -> FieldSelection s
FA
ExprX
_ -> CompileError -> Either CompileError (Text -> ExprX)
forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
let f :: (Text, ExprX) -> ExprX
f :: (Text, ExprX) -> ExprX
f (Text
key, ExprX
val) = Map Text (RecordField Src X) -> ExprX
forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit (Map Text (RecordField Src X) -> ExprX)
-> Map Text (RecordField Src X) -> ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> RecordField Src X
forall s a. Expr s a -> RecordField s a
D.makeRecordField (ExprX -> RecordField Src X)
-> Map Text ExprX -> Map Text (RecordField Src X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, ExprX)] -> Map Text ExprX
forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList
[ (Text
"mapKey" , Text -> ExprX
toKey Text
key)
, (Text
"mapValue", ExprX
val)
]
let records :: Seq ExprX
records = (((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 -> JSONPath -> CompileError
Mismatch ExprX
t Value
v JSONPath
jsonPath)
loop JSONPath
jsonPath (App ExprX
D.List ExprX
t) (Aeson.Array Array
a)
= let f :: [ExprX] -> ExprX
f :: [ExprX] -> ExprX
f [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
<$> ((Int, Value) -> Either CompileError ExprX)
-> [(Int, Value)] -> Either CompileError [ExprX]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Int
idx, Value
val) -> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop (Int -> JSONPathElement
Aeson.Types.Index Int
idx JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
jsonPath) ExprX
t Value
val) ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Item [Int]
0..] ([Value] -> [(Int, Value)]) -> [Value] -> [(Int, Value)]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a)
loop JSONPath
jsonPath t :: ExprX
t@(App ExprX
D.List ExprX
_) Value
Aeson.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 -> JSONPath -> CompileError
Mismatch ExprX
t Value
Aeson.Null JSONPath
jsonPath)
loop JSONPath
jsonPath ExprX
D.Integer (Aeson.Number Scientific
x)
| Right 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 -> JSONPath -> CompileError
Mismatch ExprX
forall s a. Expr s a
D.Integer (Scientific -> Value
Aeson.Number Scientific
x) JSONPath
jsonPath)
loop JSONPath
jsonPath ExprX
D.Natural (Aeson.Number Scientific
x)
| Right 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
>= Integer
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 -> JSONPath -> CompileError
Mismatch ExprX
forall s a. Expr s a
D.Natural (Scientific -> Value
Aeson.Number Scientific
x) JSONPath
jsonPath)
loop JSONPath
_ ExprX
D.Double (Aeson.Number 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)
loop JSONPath
_ ExprX
D.Text (Aeson.String 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))
loop JSONPath
_ ExprX
D.Bool (Aeson.Bool 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)
loop JSONPath
_ (App ExprX
D.Optional ExprX
expr) Value
Aeson.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
loop JSONPath
jsonPath (App ExprX
D.Optional ExprX
expr) 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
<$> JSONPath -> ExprX -> Value -> Either CompileError ExprX
loop JSONPath
jsonPath ExprX
expr Value
value
loop
JSONPath
_
(D.Pi Maybe CharacterSet
_ Text
_ (D.Const Const
D.Type)
(D.Pi Maybe CharacterSet
_ Text
_
(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 Int
1)
)
)
Value
value = do
let outer :: Value -> Expr s a
outer (Aeson.Object Object
o) =
let inner :: (Text, Value) -> Expr s a
inner (Text
key, Value
val) =
Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit
[ (Text
"mapKey" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
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))
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ 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 (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"mapKey", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
forall s a. Expr s a
D.Text)
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"object") Expr s a
keyValues
outer (Aeson.Array 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 Expr s a
"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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"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 (Aeson.String 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"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 (Aeson.Number 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"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 (Aeson.Bool 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"bool") (Bool -> Expr s a
forall s a. Bool -> Expr s a
D.BoolLit Bool
b)
outer Value
Aeson.Null =
Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"null"
let result :: Expr s a
result =
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam Maybe CharacterSet
forall a. Monoid a => a
mempty (Text -> Expr s a -> FunctionBinding s a
forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"JSON" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type))
(Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam Maybe CharacterSet
forall a. Monoid a => a
mempty (Text -> Expr s a -> FunctionBinding s a
forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"json"
(Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"array" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (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 Expr s a
"JSON") Expr s a
"JSON")
, (Text
"bool" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Bool Expr s a
"JSON")
, (Text
"null" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
, (Text
"number", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Double Expr s a
"JSON")
, (Text
"object", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (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 (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"mapKey", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
forall s a. Expr s a
D.Text)
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
])) Expr s a
"JSON")
, (Text
"string", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Text Expr s a
"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
loop
JSONPath
_
(D.Pi Maybe CharacterSet
_ Text
_ (D.Const Const
D.Type)
(D.Pi Maybe CharacterSet
_ Text
_
(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 Int
1)
)
)
Value
value = do
let outer :: Value -> Expr s a
outer (Aeson.Object Object
o) =
let inner :: (Text, Value) -> Expr s a
inner (Text
key, Value
val) =
Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.RecordLit
[ (Text
"mapKey" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
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))
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ 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 (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"mapKey", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
forall s a. Expr s a
D.Text)
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"object")) Expr s a
keyValues
outer (Aeson.Array 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 Expr s a
"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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"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 (Aeson.String 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"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 (Aeson.Number Scientific
n) =
case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n of
Left 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"double")) (DhallDouble -> Expr s a
forall s a. DhallDouble -> Expr s a
D.DoubleLit (Double -> DhallDouble
DhallDouble Double
floating))
Right 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"integer")) (Integer -> Expr s a
forall s a. Integer -> Expr s a
D.IntegerLit Integer
integer)
outer (Aeson.Bool 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 -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"bool")) (Bool -> Expr s a
forall s a. Bool -> Expr s a
D.BoolLit Bool
b)
outer Value
Aeson.Null =
Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
D.Field Expr s a
"json" (Text -> FieldSelection s
forall s. Text -> FieldSelection s
FA Text
"null")
let result :: Expr s a
result =
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam Maybe CharacterSet
forall a. Monoid a => a
mempty (Text -> Expr s a -> FunctionBinding s a
forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"JSON" (Const -> Expr s a
forall s a. Const -> Expr s a
D.Const Const
D.Type))
(Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
D.Lam Maybe CharacterSet
forall a. Monoid a => a
mempty (Text -> Expr s a -> FunctionBinding s a
forall s a. Text -> Expr s a -> FunctionBinding s a
D.makeFunctionBinding Text
"json"
(Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"array" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" (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 Expr s a
"JSON") Expr s a
"JSON")
, (Text
"bool" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Bool Expr s a
"JSON")
, (Text
"double", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Double Expr s a
"JSON")
, (Text
"integer", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Integer Expr s a
"JSON")
, (Text
"null" , Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")
, (Text
"object", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_"
(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 (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
D.Record
[ (Text
"mapKey", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
forall s a. Expr s a
D.Text)
, (Text
"mapValue", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField Expr s a
"JSON")])) Expr s a
"JSON")
, (Text
"string", Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
D.makeRecordField (Expr s a -> RecordField s a) -> Expr s a -> RecordField s a
forall a b. (a -> b) -> a -> b
$ Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
D.Pi Maybe CharacterSet
forall a. Monoid a => a
mempty Text
"_" Expr s a
forall s a. Expr s a
D.Text Expr s a
"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
loop JSONPath
jsonPath ExprX
expr Value
value
= CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (ExprX -> Value -> JSONPath -> CompileError
Mismatch ExprX
expr Value
value JSONPath
jsonPath)
red, purple, green
:: (Semigroup a, Data.String.IsString a) => a -> a
red :: a -> a
red a
s = a
"\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
<> a
"\ESC[0m"
purple :: a -> a
purple a
s = a
"\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
<> a
"\ESC[0m"
green :: a -> a
green a
s = a
"\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
<> a
"\ESC[0m"
showExpr :: ExprX -> String
showExpr :: ExprX -> String
showExpr 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 = ByteString -> String
BSL8.unpack (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Value
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 :: CompileError -> String
show = String -> (Value -> String) -> CompileError -> String
showCompileError String
"JSON" Value -> String
showJSON
instance Exception CompileError
showCompileError :: String -> (Value -> String) -> CompileError -> String
showCompileError :: String -> (Value -> String) -> CompileError -> String
showCompileError String
format Value -> String
showValue = let prefix :: String
prefix = ShowS
forall a. (Semigroup a, IsString a) => a -> a
red String
"\nError: "
in \case
TypeError TypeError Src X
e -> TypeError Src X -> String
forall a. Show a => a -> String
show TypeError Src X
e
BadDhallType ExprX
t ExprX
e -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"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
<> String
"\nExpected Dhall type: Type"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n"
ContainsUnion ExprX
e -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"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
<> String
"\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 String
"--unions-none\n"
UndecidableUnion ExprX
e Value
v [ExprX]
xs -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"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
<> String
" value"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n\nPossible matches:\n\n"
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 Text
"\n--------\n" :: Text
Mismatch ExprX
e Value
v JSONPath
jsonPath -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Dhall type expression and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" value do not match:"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
MissingKey Text
k ExprX
e Value
v JSONPath
jsonPath -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": 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
<> String
", 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
<> String
"\nis not present in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" 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
<> String
"\n"
UnhandledKeys [Text]
ks ExprX
e Value
v JSONPath
jsonPath -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> JSONPath -> String
showJsonPath JSONPath
jsonPath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": 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
", " [Text]
ks))
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" present in the " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" object but not in the expected Dhall"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" 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 String
"--records-loose" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" flag:"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
NoKeyValArray ExprX
e Value
v -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" (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 String
"--no-keyval-arrays" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" flag"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
NoKeyValMap ExprX
e Value
v -> String
prefix
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Homogeneous " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" 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 String
"--no-keyval-maps" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" flag"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\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
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
format String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
showValue Value
v
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
showJsonPath :: Aeson.Types.JSONPath -> String
showJsonPath :: JSONPath -> String
showJsonPath = JSONPath -> String
Aeson.Types.formatPath (JSONPath -> String)
-> (JSONPath -> JSONPath) -> JSONPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONPath -> JSONPath
forall a. [a] -> [a]
reverse