content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE TypeApplications #-}
  
  module Tests.SchemaQQ where
  
  import qualified Data.Text as Text
  import Test.Tasty
  import Test.Tasty.HUnit
  import Text.RawString.QQ (r)
  
  import TestUtils (testParseError)
  import Tests.SchemaQQ.TH
  
  test :: TestTree
  test =
    testGroup
      "`schema` quasiquoter"
      [ testValidSchemas
      , testInvalidSchemas
      , testKeys
      ]
  
  testValidSchemas :: TestTree
  testValidSchemas =
    testGroup
      "Valid schemas"
      [ testCase "Object with Bool field" $
          assertMatches
            [schemaRep| { a: Bool } |]
            [r| SchemaObject { "a": Bool } |]
      , testCase "Object with Int field" $
          assertMatches
            [schemaRep| { a: Int } |]
            [r| SchemaObject { "a": Int } |]
      , testCase "Object with Double field" $
          assertMatches
            [schemaRep| { foo123: Double } |]
            [r| SchemaObject { "foo123": Double } |]
      , testCase "Object with Text field" $
          assertMatches
            [schemaRep| { some_text: Text } |]
            [r| SchemaObject { "some_text": Text } |]
      , testCase "Object with a field with a custom type" $
          assertMatches
            [schemaRep| { status: Status } |]
            [r| SchemaObject { "status": Status } |]
      , testCase "Object with a field with a Maybe type" $
          assertMatches
            [schemaRep| { a: Maybe Bool } |]
            [r| SchemaObject { "a": Maybe Bool } |]
      , testCase "Object with a field with a Try type" $
          assertMatches
            [schemaRep| { a: Try Bool } |]
            [r| SchemaObject { "a": Try Bool } |]
      , testCase "Object with a nested object" $
          assertMatches
            [schemaRep| { a: { b: Int } } |]
            [r| SchemaObject { "a": { "b": Int } } |]
      , testCase "Object with a nullable nested object" $
          assertMatches
            [schemaRep| { a: Maybe { b: Int } } |]
            [r| SchemaObject { "a": Maybe { "b": Int } } |]
      , testCase "Object with a list of nested objects" $
          assertMatches
            [schemaRep| { a: List { b: Int } } |]
            [r| SchemaObject { "a": List { "b": Int } } |]
      , testCase "Object with an imported schema" $
          assertMatches
            [schemaRep| { user: #UserSchema } |]
            [r| SchemaObject { "user": { "name": Text } } |]
      , testCase "Object with a qualified imported schema" $
          assertMatches
            [schemaRep| { user: #(Tests.SchemaQQ.TH.UserSchema) } |]
            [r| SchemaObject { "user": { "name": Text } } |]
      , testCase "Object with an imported schema that uses a non-imported type" $
          assertMatches
            [schemaRep| { a: #SchemaWithHiddenImport } |]
            [r| SchemaObject { "a": { "a": CBool } } |]
      , testCase "Object with an imported schema that itself imports a schema" $
          assertMatches
            [schemaRep| { a: #WithUser } |]
            [r| SchemaObject { "a": { "user": { "name": Text } } } |]
      , testCase "Object with an extended schema" $
          assertMatches
            [schemaRep| { a: Int, #ExtraSchema } |]
            [r| SchemaObject { "a": Int, "extra": Text } |]
      , testCase "Object with a qualified extended schema" $
          assertMatches
            [schemaRep| { a: Int, #(Tests.SchemaQQ.TH.ExtraSchema) } |]
            [r| SchemaObject { "a": Int, "extra": Text } |]
      , testCase "Object with an extended schema that uses a non-imported type" $
          assertMatches
            [schemaRep| { #SchemaWithHiddenImport } |]
            [r| SchemaObject { "a": CBool } |]
      , testCase "Object with an extended schema with a shadowed key" $
          assertMatches
            [schemaRep| { extra: Bool, #ExtraSchema } |]
            [r| SchemaObject { "extra": Bool } |]
      , testCase "Object with a qualified extended schema with a shadowed key" $
          assertMatches
            [schemaRep| { extra: Bool, #(Tests.SchemaQQ.TH.ExtraSchema) } |]
            [r| SchemaObject { "extra": Bool } |]
      , testCase "Object with a union field" $
          assertMatches
            [schemaRep| { a: List Int | Text } |]
            [r| SchemaObject { "a": ( List Int | Text ) } |]
      , testCase "Object with a union field with a group" $
          assertMatches
            [schemaRep| { a: List (Int | Text) } |]
            [r| SchemaObject { "a": List ( Int | Text ) } |]
      , testCase "Object with a phantom key for an object" $
          assertMatches
            [schemaRep| { [a]: { b: Int } } |]
            [r| SchemaObject { [a]: { "b": Int } } |]
      , testCase "Object with a phantom key for a Maybe" $
          assertMatches
            [schemaRep| { [a]: Maybe { b: Int } } |]
            [r| SchemaObject { [a]: Maybe { "b": Int } } |]
      , testCase "Object with a phantom key for a Try" $
          assertMatches
            [schemaRep| { [a]: Try { b: Int } } |]
            [r| SchemaObject { [a]: Try { "b": Int } } |]
      , testCase "Object with a phantom key for a non-object Try" $
          assertMatches
            [schemaRep| { [a]: Try Bool } |]
            [r| SchemaObject { [a]: Try Bool } |]
      , testCase "Object with a phantom key for a union of valid schemas" $
          assertMatches
            [schemaRep| { [a]: { b: Int } | Int } |]
            [r| SchemaObject { [a]: ( { "b": Int } | Int ) } |]
      ]
  
  testInvalidSchemas :: TestTree
  testInvalidSchemas =
    testGroup
      "Invalid schemas"
      [ testCase "Object with a duplicate key" $
          [schemaErr| { a: Int, a: Bool } |] @?= "Key 'a' specified multiple times"
      , testCase "Object with a duplicate phantom key" $
          [schemaErr| { a: Int, [a]: { b: Bool } } |] @?= "Key 'a' specified multiple times"
      , testCase "Object with a duplicate key from extending" $
          [schemaErr| { #ExtraSchema, #ExtraSchema2 } |] @?= "Key 'extra' declared in multiple imported schemas"
      , testCase "Quasiquoter defining a non-object" $
          [schemaErr| List { a: Int } |] @?= "`schema` definition must be an object"
      , testCase "Object with a field with an unknown type" $
          [schemaErr| { a: HelloWorld } |] @?= "Unknown type: HelloWorld"
      , testCase "Object extending a non-schema" $
          [schemaErr| { #Int } |] @?= "'GHC.Types.Int' is not a Schema"
      , testCase "Object importing an unknown schema" $
          [schemaErr| { foo: #FooSchema } |] @?= "Unknown schema: FooSchema"
      , testCase "Object extending an unknown schema" $
          [schemaErr| { #FooSchema } |] @?= "Unknown schema: FooSchema"
      , testCase "Object with a phantom key for a scalar" $
          [schemaErr| { [a]: Int } |] @?= "Invalid schema for 'a': SchemaScalar Int"
      , testCase "Object with a phantom key for a list" $
          [schemaErr| { [a]: List Int } |] @?= "Invalid schema for 'a': SchemaList Int"
      , testCase "Object with a phantom key for a non-object Maybe" $
          [schemaErr| { [a]: Maybe Int } |] @?= "Invalid schema for 'a': SchemaMaybe Int"
      , testCase "Object with a phantom key for an invalid union" $
          [schemaErr| { [a]: Bool | Int } |] @?= "Invalid schema for 'a': SchemaUnion ( Bool | Int )"
      ]
  
  testKeys :: TestTree
  testKeys =
    testGroup
      "Keys in schemas"
      [ testCase "Quoted key same as plain key" $
          [schemaRep| { a: Int } |] @?= [schemaRep| { "a": Int } |]
      , testParseError
          "Key with invalid character"
          "schemaqq_key_with_invalid_character.golden"
          [schemaErr| { "a:b": Int } |]
      , testCase "Key with escaped invalid character" $
          assertMatches
            [schemaRep| { "a\:b": Int } |]
            [r| SchemaObject { "a:b": Int } |]
      , testParseError
          "Key with trailing escape"
          "schemaqq_key_with_trailing_escape.golden"
          [schemaErr| { "a\": Int } |]
      , testCase "Quoted key that starts with '//'" $
          assertMatches
            [schemaRep| { "//a": { b: Int } } |]
            [r| SchemaObject { "//a": { "b": Int } } |]
      , testCase "Phantom key that starts with '//'" $
          assertMatches
            [schemaRep| { [//a]: { b: Int } } |]
            [r| SchemaObject { [//a]: { "b": Int } } |]
      ]
  
  {- Helpers -}
  
  assertMatches :: String -> String -> Assertion
  assertMatches a b = strip a @?= strip b
    where
      strip = Text.unpack . Text.strip . Text.pack
  