{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
import Data.Aeson (ToJSON, decode, eitherDecode, encode)
import Data.Aeson.Schema (Object, get, unwrap)
import Data.Aeson.Schema.Utils.Sum (SumType(..), fromSumType)
import qualified Data.ByteString.Lazy.Char8 as ByteString
import Data.Char (toLower, toUpper)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import qualified Data.Text as Text
import Language.Haskell.TH.TestUtils (tryQErr')
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.Golden (goldenVsString)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.QuickCheck
(arbitrary, elements, infiniteListOf, oneof, testProperty, (===))
import Text.RawString.QQ (r)
import qualified AllTypes
import Enums
import qualified Nested
import Schema
import SumType
import Util
allTypes :: Object AllTypes.Schema
allTypes = AllTypes.result
main :: IO ()
main = defaultMain $ testGroup "aeson-schemas"
[ testGetterExp
, testFromObjectAllTypes
, testFromObjectNested
, testFromObjectNamespaced
, testUnwrapSchema
, testSchemaDef
, testMkGetter
, testEnumTH
, testSumType
]
goldens' :: String -> String -> TestTree
goldens' name = goldenVsString name fp . pure . ByteString.pack
where
fp = "test/goldens/" ++ name ++ ".golden"
goldens :: Show s => String -> s -> TestTree
goldens name = goldens' name . show
testGetterExp :: TestTree
testGetterExp = testGroup "Test getter expressions"
[ goldens "bool" [get| allTypes.bool |]
, goldens "lambda_bool" ([get| .bool |] allTypes)
, goldens "int" [get| allTypes.int |]
, goldens "int_int2" [get| allTypes.[int,int2] |]
, goldens "double" [get| allTypes.double |]
, goldens "bool_int_double" [get| allTypes.(bool,int,double) |]
, goldens "text" [get| allTypes.text |]
, goldens "scalar" [get| allTypes.scalar |]
, goldens "enum" [get| allTypes.enum |]
, goldens "maybeObj" [get| allTypes.maybeObject |]
, goldens "maybeObj_bang" [get| allTypes.maybeObject! |]
, goldens "maybeObj_text" [get| allTypes.maybeObject?.text |]
, goldens "maybeObj_bang_text" [get| allTypes.maybeObject!.text |]
, goldens "maybeObjNull" [get| allTypes.maybeObjectNull |]
, goldens "maybeObjNull_text" [get| allTypes.maybeObjectNull?.text |]
, goldens "tryObj" [get| allTypes.tryObject |]
, goldens "tryObjNull" [get| allTypes.tryObjectNull |]
, goldens "tryObj_bang" [get| allTypes.tryObject! |]
, goldens "tryObj_a" [get| allTypes.tryObject?.a |]
, goldens "tryObj_bang_a" [get| allTypes.tryObject!.a |]
, goldens "tryObjNull_a" [get| allTypes.tryObjectNull?.a |]
, goldens "maybeList" [get| allTypes.maybeList |]
, goldens "maybeList_bang" [get| allTypes.maybeList! |]
, goldens "maybeList_bang_list" [get| allTypes.maybeList![] |]
, goldens "maybeList_bang_list_text" [get| allTypes.maybeList![].text |]
, goldens "maybeList_list" [get| allTypes.maybeList?[] |]
, goldens "maybeList_list_text" [get| allTypes.maybeList?[].text |]
, goldens "maybeListNull" [get| allTypes.maybeListNull |]
, goldens "maybeListNull_list" [get| allTypes.maybeListNull?[] |]
, goldens "maybeListNull_list_text" [get| allTypes.maybeListNull?[].text |]
, goldens "list" [get| allTypes.list |]
, goldens "list_explicit" [get| allTypes.list[] |]
, goldens "list_type" [get| allTypes.list[].type |]
, goldens "list_maybeBool" [get| allTypes.list[].maybeBool |]
, goldens "list_maybeInt" [get| allTypes.list[].maybeInt |]
, goldens "nonexistent" [get| allTypes.nonexistent |]
, goldens "union" [get| allTypes.union |]
, goldens "union_0" [get| allTypes.union[]@0 |]
, goldens "union_0_a" [get| allTypes.union[]@0?.a |]
, goldens "union_1" [get| allTypes.union[]@1 |]
, goldens "union_2" [get| allTypes.union[]@2 |]
, goldens "phantom" [get| allTypes.phantom.keyForPhantom |]
-- bad 'get' expressions
, goldens' "maybeListNull_bang" $(getError [get| (AllTypes.result).maybeListNull! |])
#if MIN_VERSION_megaparsec(7,0,0)
, goldens' "get_empty" $(tryQErr' $ showGet "")
, goldens' "get_just_start" $(tryQErr' $ showGet "allTypes")
#endif
, goldens' "get_ops_after_tuple" $(tryQErr' $ showGet "allTypes.(bool,int).foo")
, goldens' "get_ops_after_list" $(tryQErr' $ showGet "allTypes.[int,int2].foo")
]
testFromObjectAllTypes :: TestTree
testFromObjectAllTypes =
goldens "from_object_all_types" $ map fromObj [get| allTypes.list |]
where
fromObj o = case Text.unpack [get| o.type |] of
"bool" -> show [get| o.maybeBool! |]
"int" -> show [get| o.maybeInt! |]
"null" -> show [get| o.maybeNull |]
_ -> error "unreachable"
testFromObjectNested :: TestTree
testFromObjectNested = goldens "from_object_nested" $ map fromObj [get| (Nested.result).list |]
where
fromObj obj = case [get| obj.a |] of
Just field -> [get| field.b |]
Nothing -> [get| obj.b |]
testFromObjectNamespaced :: TestTree
testFromObjectNamespaced = goldens "from_object_namespaced" $
map fromAllTypes [get| allTypes.list |]
++ map fromNested [get| (Nested.result).list |]
where
fromAllTypes o = Text.unpack [get| o.type |]
fromNested o = show [get| o.b |]
type NestedObject = [unwrap| (Nested.Schema).list[] |]
parseNestedObject :: NestedObject -> Int
parseNestedObject obj = fromMaybe [get| obj.b |] [get| obj.a?.b |]
nestedList :: [NestedObject]
nestedList = [get| (Nested.result).list[] |]
testUnwrapSchema :: TestTree
testUnwrapSchema = testGroup "Test unwrapping schemas"
[ goldens' "unwrap_schema" $(showUnwrap "(Nested.Schema).list[]")
, goldens "unwrap_schema_nested_list" nestedList
, goldens "unwrap_schema_nested_object" $ map parseNestedObject nestedList
-- bad unwrap types
, goldens' "unwrap_schema_bad_bang" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]!")
, goldens' "unwrap_schema_bad_question" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]?")
, goldens' "unwrap_schema_bad_list" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[][]")
, goldens' "unwrap_schema_bad_key" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list.a")
, goldens' "unwrap_schema_bad_branch" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list@0")
, goldens' "unwrap_schema_branch_out_of_bounds" $(tryQErr' $ showUnwrap "(AllTypes.Schema).union[]@10")
]
testSchemaDef :: TestTree
testSchemaDef = testGroup "Test generating schema definitions"
[ goldens' "schema_def_bool" $(showSchema [r| { a: Bool } |])
, goldens' "schema_def_int" $(showSchema [r| { a: Int } |])
, goldens' "schema_def_double" $(showSchema [r| { foo123: Double } |])
, goldens' "schema_def_text" $(showSchema [r| { some_text: Text } |])
, goldens' "schema_def_custom" $(showSchema [r| { status: Status } |])
, goldens' "schema_def_maybe" $(showSchema [r| { a: Maybe Int } |])
, goldens' "schema_def_list" $(showSchema [r| { a: List Int } |])
, goldens' "schema_def_obj" $(showSchema [r| { a: { b: Int } } |])
, goldens' "schema_def_maybe_obj" $(showSchema [r| { a: Maybe { b: Int } } |])
, goldens' "schema_def_list_obj" $(showSchema [r| { a: List { b: Int } } |])
, goldens' "schema_def_import_user" $(showSchema [r| { user: #UserSchema } |])
, goldens' "schema_def_extend" $(showSchema [r| { a: Int, #(Schema.MySchema) } |])
, goldens' "schema_def_shadow" $(showSchema [r| { extra: Bool, #(Schema.MySchema) } |])
, goldens' "schema_def_union" $(showSchema [r| { a: List Int | Text } |])
, goldens' "schema_def_union_grouped" $(showSchema [r| { a: List (Int | Text) } |])
-- bad schema definitions
, goldens' "schema_def_duplicate" $(tryQErr' $ showSchema [r| { a: Int, a: Bool } |])
, goldens' "schema_def_duplicate_phantom" $(tryQErr' $ showSchema [r| { a: Int, [a]: { b: Bool } } |])
, goldens' "schema_def_duplicate_extend" $(tryQErr' $ showSchema [r| { #MySchema, #MySchema2 } |])
, goldens' "schema_def_not_object" $(tryQErr' $ showSchema [r| List { a: Int } |])
, goldens' "schema_def_unknown_type" $(tryQErr' $ showSchema [r| HelloWorld |])
, goldens' "schema_def_invalid_extend" $(tryQErr' $ showSchema [r| { #Int } |])
, goldens' "schema_def_nonobject_phantom" $(tryQErr' $ showSchema [r| { [a]: Int } |])
]
testMkGetter :: TestTree
testMkGetter = testGroup "Test the mkGetter helper"
[ goldens "getter_all_types_list" list
, goldens "getter_all_types_list_item" $ map getType list
]
where
list :: [AllTypes.ListItem]
list = AllTypes.getList AllTypes.result
getType :: AllTypes.ListItem -> Text.Text
getType = [get| .type |]
testEnumTH :: TestTree
testEnumTH = testGroup "Test the Enum TH helpers"
-- State
[ testProperty "mkEnum decode is case insensitive" $ do
(val, enumVal) <- elements
[ ("OPEN", OPEN)
, ("CLOSED", CLOSED)
]
casedVal <- randomlyCased val
return $ decode (ByteString.pack $ show casedVal) === Just enumVal
, testCase "mkEnum encode keeps case of constructor" $ do
encode OPEN @?= "\"OPEN\""
encode CLOSED @?= "\"CLOSED\""
, testProperty "mkEnum: (fromJust . decode . encode) === id" $ do
enumVal <- elements [OPEN, CLOSED]
return $ (decode . encode) enumVal === Just enumVal
-- Color
, testProperty "genFromJSONEnum decode is case insensitive" $ do
(val, enumVal) <- elements
[ ("Red", Red)
, ("LightBlue", LightBlue)
, ("Yellow", Yellow)
, ("DarkGreen", DarkGreen)
, ("Black", Black)
, ("JustABitOffWhite", JustABitOffWhite)
]
casedVal <- randomlyCased val
return $ decode (ByteString.pack $ show casedVal) === Just enumVal
, testCase "genToJSONEnum encode keeps case of constructor" $ do
encode Red @?= "\"Red\""
encode LightBlue @?= "\"LightBlue\""
encode Yellow @?= "\"Yellow\""
encode DarkGreen @?= "\"DarkGreen\""
encode Black @?= "\"Black\""
encode JustABitOffWhite @?= "\"JustABitOffWhite\""
, testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do
enumVal <- elements
[ Red
, LightBlue
, Yellow
, DarkGreen
, Black
, JustABitOffWhite
]
return $ (decode . encode) enumVal === Just enumVal
]
where
randomlyCased s = do
caseFuncs <- infiniteListOf $ elements [toLower, toUpper]
return $ zipWith ($) caseFuncs s
testSumType :: TestTree
testSumType = testGroup "Test the SumType helper"
[ testCase "Sanity checks" $
let values =
[ Here True
, Here False
, There (Here 1)
, There (Here 10)
, There (There (Here []))
, There (There (Here ["a"]))
] :: [SpecialJSON]
in values @?= values
, testGroup "Decode SumType"
[ testProperty "branch 1" $ \(b :: Bool) ->
toSpecialJSON b === Right (Here b)
, testProperty "branch 2" $ \(x :: Int) ->
toSpecialJSON x === Right (There (Here x))
, testProperty "branch 3" $ \(l :: [String]) ->
toSpecialJSON l === Right (There (There (Here l)))
, testCase "invalid SumType" $
toSpecialJSON [True] @?= Left "Error in $: Could not parse sum type"
]
, testGroup "fromSumType"
[ testProperty "branch 0 valid" $ \b ->
fromSumType (Proxy @0) (Here b :: SpecialJSON) === Just b
, testProperty "branch 0 invalid" $ do
value <- oneof
[ There . Here <$> arbitrary
, There . There . Here <$> arbitrary
]
return $ fromSumType (Proxy @0) (value :: SpecialJSON) === Nothing
, testProperty "branch 1 valid" $ \x ->
fromSumType (Proxy @1) (There (Here x) :: SpecialJSON) === Just x
, testProperty "branch 1 invalid" $ do
value <- oneof
[ Here <$> arbitrary
, There . There . Here <$> arbitrary
]
return $ fromSumType (Proxy @1) (value :: SpecialJSON) === Nothing
, testProperty "branch 2 valid" $ \l ->
fromSumType (Proxy @2) (There (There (Here l)) :: SpecialJSON) === Just l
, testProperty "branch 2 invalid" $ do
value <- oneof
[ Here <$> arbitrary
, There . Here <$> arbitrary
]
return $ fromSumType (Proxy @2) (value :: SpecialJSON) === Nothing
]
]
where
toSpecialJSON :: ToJSON a => a -> Either String SpecialJSON
toSpecialJSON = eitherDecode . encode