CoreCodersSpec.hs

module Hydra.CoreCodersSpec where

import Hydra.Kernel
import Hydra.Dsl.Terms as Terms
import qualified Hydra.Dsl.Types as Types
import qualified Hydra.Decode.Core as DecodeCore
import qualified Hydra.Encode.Core as EncodeCore

import Hydra.TestData
import Hydra.TestUtils
import Hydra.ArbitraryCore (untyped)

import qualified Test.Hspec as H
import qualified Test.QuickCheck as QC
import qualified Data.Map as M


individualEncoderTestCases :: H.SpecWith ()
individualEncoderTestCases = do
  H.describe "Individual encoder test cases" $ do

    H.it "string literal type" $ do
      H.shouldBe
        (strip $ EncodeCore.literalType LiteralTypeString :: Term)
        (strip $ unitVariant _LiteralType _LiteralType_string)

    H.it "string type" $ do
      H.shouldBe
        (strip $ EncodeCore.type_ Types.string :: Term)
        (strip $ variant _Type _Type_literal (unitVariant _LiteralType _LiteralType_string))

    H.it "int32 type" $ do
      H.shouldBe
        (strip $ EncodeCore.type_ Types.int32 :: Term)
        (strip $ variant _Type _Type_literal (variant _LiteralType _LiteralType_integer $ unitVariant _IntegerType _IntegerType_int32))

    H.it "record type" $ do
      H.shouldBe
        (strip $ EncodeCore.type_ (TypeRecord $ RowType (Name "Example")
          [Types.field "something" Types.string, Types.field "nothing" Types.unit]) :: Term)
        (strip $ variant _Type _Type_record $
          record _RowType [
            Field _RowType_typeName $ wrap _Name $ string "Example",
            Field _RowType_fields $ list [
              record _FieldType [
                Field _FieldType_name $ wrap _Name $ string "something",
                Field _FieldType_type $ variant _Type _Type_literal $ unitVariant _LiteralType _LiteralType_string],
              record _FieldType [
                Field _FieldType_name $ wrap _Name $ string "nothing",
                Field _FieldType_type $ unitVariant _Type _Type_unit]]])

individualDecoderTestCases :: H.SpecWith ()
individualDecoderTestCases = do
  H.describe "Individual decoder test cases" $ do

    H.it "float32 literal type" $ do
      shouldSucceedWith
        (DecodeCore.literalType
          (variant _LiteralType _LiteralType_float $ unitVariant _FloatType _FloatType_float32))
        (LiteralTypeFloat FloatTypeFloat32)

    H.it "float32 type" $ do
      shouldSucceedWith
        (DecodeCore.type_
          (variant _Type _Type_literal $ variant _LiteralType _LiteralType_float $ unitVariant _FloatType _FloatType_float32))
        Types.float32

    H.it "union type" $ do
      shouldSucceedWith
        (DecodeCore.type_ $
          variant _Type _Type_union $ record _RowType [
            Field _RowType_typeName $ wrap _Name $ string (unName testTypeName),
            Field _RowType_fields $
              list [
                record _FieldType [
                  Field _FieldType_name $ wrap _Name $ string "left",
                  Field _FieldType_type $ variant _Type _Type_literal $ variant _LiteralType _LiteralType_integer $
                    unitVariant _IntegerType _IntegerType_int64],
                record _FieldType [
                  Field _FieldType_name $ wrap _Name $ string "right",
                  Field _FieldType_type $ variant _Type _Type_literal $ variant _LiteralType _LiteralType_float $
                    unitVariant _FloatType _FloatType_float64]]])
          (TypeUnion $ RowType testTypeName [
            Types.field "left" Types.int64,
            Types.field "right" Types.float64])

decodeInvalidTerms :: H.SpecWith ()
decodeInvalidTerms = do
  H.describe "Decode invalid terms" $ do

    H.it "Try to decode a term with wrong fields for Type" $ do
      shouldFail (DecodeCore.type_ $ variant untyped (Name "unknownField") $ list [])

    H.it "Try to decode an incomplete representation of a Type" $ do
      shouldFail (DecodeCore.type_ $ variant _Type _Type_literal $ unitVariant _LiteralType _LiteralType_integer)

metadataIsPreserved :: H.SpecWith ()
metadataIsPreserved = do
  H.describe "Check that metadata is preserved through a type-encoding round trip" $ do

    H.it "Basic metadata" $ do
      shouldSucceedWith
        (DecodeCore.type_ $ EncodeCore.type_ annotatedStringType)
        annotatedStringType
  where
    annotatedStringType :: Type
    annotatedStringType = TypeAnnotated $ AnnotatedType Types.string $ M.fromList [
      (key_description, Terms.string "The string literal type"),
      (key_type, EncodeCore.type_ $ TypeVariable _Type)]

testRoundTripsFromType :: H.SpecWith ()
testRoundTripsFromType = do
  H.describe "Check that encoding, then decoding random types is a no-op" $ do

    H.it "Try random types" $
      QC.property $ \typ ->
        shouldSucceedWith
          (DecodeCore.type_ $ EncodeCore.type_ typ)
          typ

spec :: H.Spec
spec = do
  individualEncoderTestCases
  individualDecoderTestCases
  decodeInvalidTerms
  metadataIsPreserved
  testRoundTripsFromType