{-# 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 Data.Void (Void)
import qualified Options.Applicative as O
import Options.Applicative (Parser)
import Dhall.JSON.Util (pattern V)
import qualified Dhall.Core as D
import Dhall.Core (Expr(App), Chunks(..), DhallDouble(..))
import qualified Dhall.Import
import qualified Dhall.Map as Map
import qualified Dhall.Parser
import Dhall.Parser (Src)
import qualified Dhall.TypeCheck as D
parseConversion :: Parser Conversion
parseConversion = Conversion <$> parseStrict
<*> parseKVArr
<*> parseKVMap
<*> parseUnion
<*> parseOmissibleLists
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"
)
parseOmissibleLists = O.switch
( O.long "omissible-lists"
<> O.help "Tolerate missing list values, they are assumed empty"
)
parseUnion :: Parser UnionConv
parseUnion =
uFirst
<|> uNone
<|> uStrict
<|> pure UFirst
where
uFirst = O.flag' UFirst
( O.long "unions-first"
<> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)"
)
uNone = O.flag' UNone
( O.long "unions-none"
<> O.help "Unions not allowed"
)
uStrict = O.flag' UStrict
( O.long "unions-strict"
<> O.help "Error if more than one union values match the type (and parse successfully)"
)
data Conversion = Conversion
{ strictRecs :: Bool
, noKeyValArr :: Bool
, noKeyValMap :: Bool
, unions :: UnionConv
, omissibleLists :: Bool
} deriving Show
data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
defaultConversion :: Conversion
defaultConversion = Conversion
{ strictRecs = False
, noKeyValArr = False
, noKeyValMap = False
, unions = UFirst
, omissibleLists = False
}
type ExprX = Expr Src Void
resolveSchemaExpr :: Text
-> IO ExprX
resolveSchemaExpr code = do
parsedExpression <-
case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of
Left err -> throwIO err
Right parsedExpression -> return parsedExpression
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')
| App D.List _ <- t
, omissibleLists
= Right (D.ListLit (Just 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 t@(App D.List _) (A.Null)
= if omissibleLists
then Right (D.ListLit (Just t) [])
else Left (Mismatch t A.Null)
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 $ DhallDouble $ 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 (DhallDouble (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 Void)
| 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"