{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Dhall.JSONToDhall (
parseConversion
, Conversion(..)
, defaultConversion
, resolveSchemaExpr
, typeCheckSchemaExpr
, dhallFromJSON
, CompileError(..)
, showCompileError
) where
import Control.Applicative ((<|>))
import Control.Exception (Exception, throwIO)
import Control.Monad.Catch (throwM, MonadCatch)
import qualified Data.Aeson as A
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BSL8
import Data.Either (rights)
import Data.Foldable (toList)
import qualified Data.HashMap.Strict as HM
import Data.List ((\\))
import Data.Monoid ((<>))
import Data.Scientific (floatingOrInteger, toRealFloat)
import qualified Data.Sequence as Seq
import qualified Data.String
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Vector as Vector
import qualified Options.Applicative as O
import Options.Applicative (Parser)
import Dhall.JSON.Util (pattern V)
import qualified Dhall.Core as D
import Dhall.Core (Expr(App), Chunks(..))
import qualified Dhall.Import
import qualified Dhall.Map as Map
import qualified Dhall.Parser
import Dhall.Parser (Src)
import qualified Dhall.TypeCheck as D
import Dhall.TypeCheck (X)
parseConversion :: Parser Conversion
parseConversion = Conversion <$> parseStrict
<*> parseKVArr
<*> parseKVMap
<*> parseUnion
where
parseStrict =
O.flag' True
( O.long "records-strict"
<> O.help "Fail if any YAML fields are missing from the expected Dhall type"
)
<|> O.flag' False
( O.long "records-loose"
<> O.help "Tolerate YAML 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"
)
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
} deriving Show
data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
defaultConversion :: Conversion
defaultConversion = Conversion
{ strictRecs = False
, noKeyValArr = False
, noKeyValMap = False
, unions = UFirst
}
type ExprX = Expr Src X
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
D.normalize <$> 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 :: A.Value -> Maybe (Text, A.Value)
keyValMay (A.Object o) = do
A.String k <- HM.lookup "key" o
v <- HM.lookup "value" o
return (k, v)
keyValMay _ = Nothing
dhallFromJSON
:: Conversion -> ExprX -> A.Value -> Either CompileError ExprX
dhallFromJSON (Conversion {..}) expressionType =
loop (D.alphaNormalize (D.normalize expressionType))
where
loop t@(D.Union tm) v = do
let f key maybeType =
case maybeType of
Just _type -> do
expression <- loop _type v
return (D.App (D.Field t key) expression)
Nothing -> do
case v of
A.String text | key == text -> do
return (D.Field t key)
_ -> do
Left (Mismatch t v)
case (unions, rights (toList (Map.mapWithKey f tm))) of
(UNone , _ ) -> Left (ContainsUnion t)
(UStrict, xs@(_:_:_)) -> Left (UndecidableUnion t v xs)
(_ , [ ] ) -> Left (Mismatch t v)
(UFirst , x:_ ) -> Right x
(UStrict, [x] ) -> Right x
loop (D.Record r) v@(A.Object o)
| extraKeys <- HM.keys o \\ Map.keys r
, strictRecs && not (null extraKeys)
= Left (UnhandledKeys extraKeys (D.Record r) v)
| otherwise
= let f :: Text -> ExprX -> Either CompileError ExprX
f k t | Just value <- HM.lookup k o
= loop t value
| App D.Optional t' <- t
= Right (App D.None t')
| otherwise
= Left (MissingKey k t v)
in D.RecordLit <$> Map.traverseWithKey f r
loop t@(D.Record _) v@(A.Array a)
| not noKeyValArr
, os :: [A.Value] <- toList a
, Just kvs <- traverse keyValMay os
= loop t (A.Object $ HM.fromList kvs)
| noKeyValArr
= Left (NoKeyValArray t v)
| otherwise
= Left (Mismatch t v)
loop t@(App D.List (D.Record r)) v@(A.Object o)
| not noKeyValMap
, ["mapKey", "mapValue"] == Map.keys r
, Just mapKey <- Map.lookup "mapKey" r
, Just mapValue <- Map.lookup "mapValue" r
= do
keyExprMap <- traverse (loop mapValue) o
toKey <- do
case mapKey of
D.Text -> return (\key -> D.TextLit (Chunks [] key))
D.Union _ -> return (\key -> D.Field mapKey key)
_ -> Left (Mismatch t v)
let f :: (Text, ExprX) -> ExprX
f (key, val) = D.RecordLit ( 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)
loop (App D.List t) (A.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 (loop t) (toList a)
loop D.Integer (A.Number x)
| Right n <- floatingOrInteger x :: Either Double Integer
= Right (D.IntegerLit n)
| otherwise
= Left (Mismatch D.Integer (A.Number x))
loop D.Natural (A.Number x)
| Right n <- floatingOrInteger x :: Either Double Integer
, n >= 0
= Right (D.NaturalLit (fromInteger n))
| otherwise
= Left (Mismatch D.Natural (A.Number x))
loop D.Double (A.Number x)
= Right (D.DoubleLit $ toRealFloat x)
loop D.Text (A.String t)
= Right (D.TextLit (Chunks [] t))
loop D.Bool (A.Bool t)
= Right (D.BoolLit t)
loop (App D.Optional expr) A.Null
= Right $ App D.None expr
loop (App D.Optional expr) value
= D.Some <$> loop expr value
loop
(D.Pi _ (D.Const D.Type)
(D.Pi _
(D.Record
[ ("array" , D.Pi _ (D.App D.List (V 0)) (V 1))
, ("bool" , D.Pi _ D.Bool (V 1))
, ("null" , V 0)
, ("number", D.Pi _ D.Double (V 1))
, ("object", D.Pi _ (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))
, ("string", D.Pi _ D.Text (V 1))
]
)
(V 1)
)
)
value = do
let outer (A.Object o) =
let inner (key, val) =
D.RecordLit
[ ("mapKey" , D.TextLit (D.Chunks [] key))
, ("mapValue", outer val )
]
elements = Seq.fromList (fmap inner (HM.toList o))
elementType
| null elements =
Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ]))
| otherwise =
Nothing
keyValues = D.ListLit elementType elements
in (D.App (D.Field "json" "object") keyValues)
outer (A.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" "array") (D.ListLit elementType elements)
outer (A.String s) =
D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s))
outer (A.Number n) =
D.App (D.Field "json" "number") (D.DoubleLit (toRealFloat n))
outer (A.Bool b) =
D.App (D.Field "json" "bool") (D.BoolLit b)
outer A.Null =
D.Field "json" "null"
let result =
D.Lam "JSON" (D.Const D.Type)
(D.Lam "json"
(D.Record
[ ("array" , D.Pi "_" (D.App D.List "JSON") "JSON")
, ("bool" , D.Pi "_" D.Bool "JSON")
, ("null" , "JSON")
, ("number", D.Pi "_" D.Double "JSON")
, ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON")])) "JSON")
, ("string", D.Pi "_" D.Text "JSON")
]
)
(outer value)
)
return result
loop expr value
= Left (Mismatch expr value)
red, purple, green
:: (Monoid 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 :: A.Value -> String
showJSON value = BSL8.unpack (encodePretty value)
data CompileError
= TypeError (D.TypeError Src X)
| BadDhallType
ExprX
ExprX
| Mismatch
ExprX
A.Value
| MissingKey Text ExprX A.Value
| UnhandledKeys [Text] ExprX A.Value
| NoKeyValArray ExprX A.Value
| NoKeyValMap ExprX A.Value
| ContainsUnion ExprX
| UndecidableUnion ExprX A.Value [ExprX]
instance Show CompileError where
show = showCompileError "JSON" showJSON
instance Exception CompileError
showCompileError :: String -> (A.Value -> String) -> CompileError -> String
showCompileError format showValue = let prefix = red "\nError: "
in \case
TypeError e -> show e
BadDhallType t e -> prefix
<> "Schema expression is succesfully 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 -> prefix
<> "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 -> prefix
<> "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 -> prefix
<> "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-arrays" <> " flag"
<> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"