SchemaQQ.hs

{-# 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 Tests.SchemaQQ.TH
import TestUtils (testParseError)

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