{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
import Data.Aeson.Schema (Object, get, unwrap)
import qualified Data.ByteString.Lazy.Char8 as ByteString
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import Language.Haskell.TH.TestUtils (tryQErr')
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.Golden (goldenVsString)
import Text.RawString.QQ (r)
import qualified AllTypes
import qualified Nested
import Schema
import Util
allTypes :: Object AllTypes.Schema
allTypes = AllTypes.result
main :: IO ()
main = defaultMain $ testGroup "aeson-schemas"
[ testGetterExp
, testFromObjectAllTypes
, testFromObjectNested
, testFromObjectNamespaced
, testUnwrapSchema
, testSchemaDef
, testMkGetter
]
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 "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 |]
-- 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")
]
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) } |])
-- bad schema definitions
, goldens' "schema_def_duplicate" $(tryQErr' $ showSchema [r| { a: Int, a: 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 } |])
]
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 |]