content: module Hydra.Adapt.TermsSpec where
  
  import Hydra.Kernel
  import Hydra.Adapt.Terms
  import Hydra.Adapt.Utils
  import Hydra.Dsl.Terms as Terms
  import qualified Hydra.Dsl.Types as Types
  import Hydra.Dsl.Tests
  
  import Hydra.TestData
  import Hydra.TestUtils
  
  import qualified Test.Hspec as H
  import qualified Data.Map as M
  import qualified Test.QuickCheck as QC
  import qualified Data.Set as S
  import qualified Data.Maybe as Y
  
  
  constraintsAreAsExpected :: H.SpecWith ()
  constraintsAreAsExpected = H.describe "Verify that the language constraints include/exclude the appropriate types" $ do
  
      H.it "int16, int32, and bigint are supported in the test context" $ do
        typeIsSupported (context [TypeVariantLiteral]) Types.int16 `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral]) Types.int32 `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral]) Types.bigint `H.shouldBe` True
  
      H.it "int8 and uint32 are unsupported in the test context" $ do
        typeIsSupported (context [TypeVariantLiteral]) Types.int8 `H.shouldBe` False
        typeIsSupported (context [TypeVariantLiteral]) Types.uint32 `H.shouldBe` False
  
      -- Note: floating-point constraints are untested
  
      H.it "Records are supported, but unions are not" $ do
        typeIsSupported (context [TypeVariantLiteral, TypeVariantRecord]) testTypeLatLon `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral, TypeVariantRecord]) stringOrIntType `H.shouldBe` False
  
      H.it "Records are supported if and only if each of their fields are supported" $ do
        typeIsSupported (context [TypeVariantLiteral, TypeVariantRecord])
          (TypeRecord $ RowType (Name "Example") [Types.field "first" Types.string, Types.field "second" Types.int16])
          `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral, TypeVariantRecord])
          (TypeRecord $ RowType (Name "Example") [Types.field "first" Types.string, Types.field "second" Types.int8])
          `H.shouldBe` False
  
      H.it "Lists are supported if the list element type is supported" $ do
        typeIsSupported (context [TypeVariantLiteral, TypeVariantList]) listOfStringsType `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral, TypeVariantList]) listOfListsOfStringsType `H.shouldBe` True
        typeIsSupported (context [TypeVariantLiteral, TypeVariantList]) listOfSetOfStringsType `H.shouldBe` False
  
    where
      context = languageConstraints . adapterContextLanguage . termTestContext
  
  supportedConstructorsAreUnchanged :: H.SpecWith ()
  supportedConstructorsAreUnchanged = H.describe "Verify that supported term constructors are unchanged" $ do
  
    H.it "Strings (and other supported literal values) pass through without change" $
      QC.property $ \b -> checkDataAdapter
        [TypeVariantLiteral]
        Types.string
        Types.string
        False
        (string b)
        (string b)
  
    H.it "Lists (when supported) pass through without change" $
      QC.property $ \strings -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantList]
        listOfStringsType
        listOfStringsType
        False
        (list $ string <$> strings)
        (list $ string <$> strings)
  
    H.it "Maps (when supported) pass through without change" $
      QC.property $ \keyvals -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantMap]
        mapOfStringsToIntsType
        mapOfStringsToIntsType
        False
        (makeMap keyvals)
        (makeMap keyvals)
  
    H.it "Optionals (when supported) pass through without change" $
      QC.property $ \mi -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantOptional]
        optionalInt8Type
        optionalInt16Type
        False
        (optional $ int8 <$> mi)
        (optional $ int16 . fromIntegral <$> mi)
  
    H.it "Records (when supported) pass through without change" $
      QC.property $ \a1 a2 -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantRecord]
        (TypeRecord $ RowType testTypeName [Types.field "first" Types.string, Types.field "second" Types.int8])
        (TypeRecord $ RowType testTypeName [Types.field "first" Types.string, Types.field "second" Types.int16])
        False
        (record testTypeName [field "first" $ string a1, field "second" $ int8 a2])
        (record testTypeName [field "first" $ string a1, field "second" $ int16 $ fromIntegral a2])
  
    H.it "Unions (when supported) pass through without change" $
      QC.property $ \int -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantUnion]
        stringOrIntType
        stringOrIntType
        False
        (variant stringOrIntName (Name "right") $ int32 int)
        (variant stringOrIntName (Name "right") $ int32 int)
  
    H.it "Sets (when supported) pass through without change" $
      QC.property $ \strings -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantSet]
        setOfStringsType
        setOfStringsType
        False
        (stringSet strings)
        (stringSet strings)
  
    H.it "Primitive function references (when supported) pass through without change" $
      QC.property $ \name -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantFunction]
        concatType
        concatType
        False
        (primitive name)
        (primitive name)
  
    H.it "Projections (when supported) pass through without change" $
      QC.property $ \fname -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantFunction, TypeVariantRecord]
        exampleProjectionType
        exampleProjectionType
        False
        (project testTypePersonName fname)
        (project testTypePersonName fname)
  
  unsupportedConstructorsAreModified :: H.SpecWith ()
  unsupportedConstructorsAreModified = H.describe "Verify that unsupported term constructors are changed in the expected ways" $ do
  
    H.it "Sets (when unsupported) become lists" $
      QC.property $ \strings -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantList]
        setOfStringsType
        listOfStringsType
        False
        (stringSet strings)
        (stringList $ S.toList strings)
  
    H.it "Optionals (when unsupported) become lists" $
      QC.property $ \ms -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantList]
        (Types.optional Types.string)
        (Types.list Types.string)
        False
        (optional $ string <$> ms)
        (list $ Y.maybe [] (\s -> [string s]) ms)
  
    H.it "Primitive function references (when unsupported) become variant terms" $
      QC.property $ \name -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantUnion, TypeVariantRecord]
        concatType
        (functionProxyType Types.string)
        False
        (primitive name)
        (inject functionProxyName $ field "primitive" $ string $ unName name) -- Note: the function name is not dereferenced
  
  --  H.it "Projections (when unsupported) become variant terms" $
  --    QC.property $ \fname -> checkDataAdapter
  --      [TypeVariantLiteral, TypeVariantUnion, TypeVariantRecord]
  --      exampleProjectionType
  --      (functionProxyType testTypePerson)
  --      False
  --      (project testTypePersonName fname)
  --      (inject functionProxyName $ field "record" $ string $
  --        show (project testTypePersonName fname :: Term)) -- Note: the field name is not dereferenced
  
  --  H.it "Nominal types (when unsupported) are dereferenced" $
  --    QC.property $ \s -> checkDataAdapter
  --      [TypeVariantLiteral, TypeVariantAnnotated]
  --      testTypeStringAlias
  --      (TypeAnnotated $ Annotated Types.string $ Kv $
  --        M.fromList [(key_description, Terms.string "An alias for the string type")])
  --      False
  --      (string s)
  --      (string s)
  
    H.it "Unions (when unsupported) become records" $
      QC.property $ \i -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantOptional, TypeVariantRecord]
        eitherStringOrInt8Type
        (TypeRecord $ RowType eitherStringOrInt8TypeName [
          Types.field "left" $ Types.optional Types.string,
          Types.field "right" $ Types.optional Types.int16])
        False
        (inject eitherStringOrInt8TypeName $ field "right" $ int8 i)
        (record eitherStringOrInt8TypeName [
          field "left" $ optional Nothing,
          field "right" $ optional $ Just $ int16 $ fromIntegral i])
  
  termsAreAdaptedRecursively :: H.SpecWith ()
  termsAreAdaptedRecursively = H.describe "Verify that the adapter descends into subterms and transforms them appropriately" $ do
  
    H.it "A list of int8's becomes a list of int32's" $
      QC.property $ \ints -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantList]
        listOfInt8sType
        listOfInt16sType
        False
        (list $ int8 <$> ints)
        (list $ int16 . fromIntegral <$> ints)
  
    H.it "A list of sets of strings becomes a list of lists of strings" $
      QC.property $ \lists -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantList]
        listOfSetOfStringsType
        listOfListsOfStringsType
        False
        (list $ (\l -> set $ S.fromList $ string <$> l) <$> lists)
        (list $ (\l -> list $ string <$> S.toList (S.fromList l)) <$> lists)
  
    H.it "A wrapped int64 becomes a wrapped bigint" $
      QC.property $ \i -> checkDataAdapter
        [TypeVariantLiteral, TypeVariantWrap]
        (Types.wrapWithName aliasName Types.int64)
        (Types.wrapWithName aliasName Types.bigint)
        False
        (wrap aliasName $ int64 i)
        (wrap aliasName $ bigint $ fromIntegral i)
    where
      aliasName = Name "MyAlias"
  
  roundTripsPreserveSelectedTypes :: H.SpecWith ()
  roundTripsPreserveSelectedTypes = H.describe "Verify that the adapter is information preserving, i.e. that round-trips are no-ops" $ do
  
    H.it "Check strings (pass-through)" $
      QC.property $ \s -> roundTripIsNoop Types.string (string s)
  
    H.it "Check lists (pass-through)" $
      QC.property $ \strings -> roundTripIsNoop listOfStringsType (list $ string <$> strings)
  
    H.it "Check sets (which map to lists)" $
      QC.property $ \strings -> roundTripIsNoop setOfStringsType (stringSet strings)
  
    H.it "Check primitive function references (which map to variants)" $
      QC.property $ \name -> roundTripIsNoop concatType (primitive name)
  
  --  H.it "Check projection terms (which map to variants)" $
  --    QC.property $ \fname -> roundTripIsNoop exampleProjectionType (project testTypePersonName fname)
  
    H.it "Check newtype terms (which pass through as instances of the aliased type)" $
      QC.property $ \s -> roundTripIsNoop testTypeStringAlias (wrap testTypeStringAliasName $ string s)
  
  --roundTripsPreserveArbitraryTypes :: H.SpecWith ()
  --roundTripsPreserveArbitraryTypes = H.describe "Verify that the adapter is information preserving for arbitrary typed terms" $ do
  --
  --  H.it "Check arbitrary type/term pairs" $
  --    QC.property $ \(TypedTerm term typ) -> roundTripIsNoop typ term
  
  fieldAdaptersAreAsExpected :: H.SpecWith ()
  fieldAdaptersAreAsExpected = H.describe "Check that field adapters are as expected" $ do
  
    H.it "An int8 field becomes an int16 field" $
      QC.property $ \i -> checkFieldAdapter
        [TypeVariantLiteral, TypeVariantRecord]
        (Types.field "second" Types.int8)
        (Types.field "second" Types.int16)
        False
        (field "second" $ int8 i)
        (field "second" $ int16 $ fromIntegral i)
  
  roundTripIsNoop :: Type -> Term -> H.Expectation
  roundTripIsNoop typ term = shouldSucceedWith
     (step coderEncode term >>= step coderDecode)
     term
    where
      step = adapt typ
  
      -- Use a YAML-like language (but supporting unions) as the default target language
      testLanguage = Language (LanguageName "hydra.test") $ LanguageConstraints {
        languageConstraintsEliminationVariants = S.empty, -- S.fromList eliminationVariants,
        languageConstraintsLiteralVariants = S.fromList [
          LiteralVariantBoolean, LiteralVariantFloat, LiteralVariantInteger, LiteralVariantString],
        languageConstraintsFloatTypes = S.fromList [FloatTypeBigfloat],
        languageConstraintsFunctionVariants = S.empty,
        languageConstraintsIntegerTypes = S.fromList [IntegerTypeBigint],
        languageConstraintsTermVariants = S.fromList termVariants,
        languageConstraintsTypeVariants = S.fromList [
          TypeVariantAnnotated, TypeVariantLiteral, TypeVariantList, TypeVariantMap, TypeVariantRecord, TypeVariantUnion],
        languageConstraintsTypes = \typ -> case deannotateType typ of
          TypeOptional (TypeOptional _) -> False
          _ -> True }
  
      -- Note: in a real application, you wouldn't create the adapter just to use it once;
      --       it should be created once, then applied to many terms.
      adapt typ dir term = do
        adapter <- languageAdapter testLanguage typ
        dir (adapterCoder adapter) term
  
  spec :: H.Spec
  spec = do
    constraintsAreAsExpected
    supportedConstructorsAreUnchanged
    unsupportedConstructorsAreModified
    termsAreAdaptedRecursively
    roundTripsPreserveSelectedTypes
  --  roundTripsPreserveArbitraryTypes -- TODO: restore me
    fieldAdaptersAreAsExpected
  