content: {-
  stack ghci hydra:lib hydra:hydra-test
  
  Test.Hspec.hspec Hydra.Staging.Json.CoderSpec.spec
  -}
  module Hydra.Staging.Json.CoderSpec where
  
  import Hydra.Kernel
  import Hydra.Lib.Literals
  import Hydra.Ext.Org.Json.Coder
  import qualified Hydra.Dsl.Terms as Terms
  import qualified Hydra.Json as Json
  import qualified Hydra.Dsl.Types as Types
  import Hydra.Dsl.Tests
  
  import Hydra.TestData
  import Hydra.TestUtils
  
  import qualified Data.Bifunctor as BF
  import qualified Test.Hspec as H
  import qualified Test.HUnit.Lang as HL
  import qualified Data.Map as M
  import qualified Data.Set as S
  import qualified Data.Maybe as Y
  import qualified Test.QuickCheck as QC
  
  
  literalTypeConstraintsAreRespected :: H.SpecWith ()
  literalTypeConstraintsAreRespected = H.describe "Verify that JSON's literal type constraints are respected" $ do
  
    -- TODO: binary data
  
    H.it "Check booleans" $
      QC.property $ \b -> checkJsonCoder Types.boolean (Terms.boolean b) (Json.ValueBoolean b)
  
    H.it "Check 32-bit floats" $
      QC.property $ \f -> checkJsonCoder Types.float32 (Terms.float32 f) (jsonFloat $ realToFrac f)
  
    H.it "Check 64-bit floats (doubles)" $
      QC.property $ \d -> checkJsonCoder Types.float64 (Terms.float64 d) (jsonFloat $ realToFrac d)
  
    -- TODO: bigfloat
  
    H.it "Check 32-bit integers" $
      QC.property $ \i -> checkJsonCoder Types.int32 (Terms.int32 i) (jsonInt i)
  
    H.it "Check 16-bit unsigned integers" $
      QC.property $ \i -> checkJsonCoder Types.uint16 (Terms.uint16 i) (jsonInt i)
  
    H.it "Check arbitrary-precision integers" $
      QC.property $ \i -> checkJsonCoder Types.bigint (Terms.bigint i) (jsonInt i)
  
    H.it "Check strings" $
      QC.property $ \s -> checkJsonCoder Types.string (Terms.string s) (Json.ValueString s)
  
  supportedTypesPassThrough :: H.SpecWith ()
  supportedTypesPassThrough = H.describe "Verify that supported types are mapped directly" $ do
  
    H.it "Lists become JSON arrays" $
      QC.property $ \strings -> checkJsonCoder listOfStringsType
        (Terms.list $ Terms.string <$> strings) (Json.ValueArray $ Json.ValueString <$> strings)
  
    H.it "Maps become JSON objects" $
      QC.property $ \keyvals -> checkJsonCoder mapOfStringsToIntsType
        (makeMap keyvals) (jsonMap $ BF.bimap id jsonInt <$> keyvals)
  
    H.it "Optionals become JSON null or type-specific values" $
      QC.property $ \ms -> checkJsonCoder optionalStringType
        (Terms.optional $ Terms.string <$> ms) (Y.maybe Json.ValueNull Json.ValueString ms)
  
    H.it "Records become JSON objects" $
      QC.property $ \lat lon -> checkJsonCoder testTypeLatLon
        (latlonRecord lat lon) (jsonMap [
          ("lat", jsonFloat $ realToFrac lat),
          ("lon", jsonFloat $ realToFrac lon)])
  
  unsupportedTypesAreTransformed :: H.SpecWith ()
  unsupportedTypesAreTransformed = H.describe "Verify that unsupported types are transformed appropriately" $ do
  
    -- TODO: functions
  
    H.it "Sets become arrays" $
      QC.property $ \strings -> checkJsonCoder setOfStringsType
        (stringSet strings)
        (Json.ValueArray $ Json.ValueString <$> S.toList strings)
  
    H.it "Nominal types are dereferenced" $
      QC.property $ \s -> checkJsonCoder testTypeStringAlias
        (Terms.wrap testTypeStringAliasName $ Terms.string s)
        (Json.ValueString s)
  
    -- TODO: restore me
  --  H.it "Unions become JSON objects (as records)" $
  --    QC.property $ \int -> checkJsonCoder stringOrIntType
  --      (Terms.inject stringOrIntName $ Field (Name "right") $ Terms.int32 int)
  --      (jsonMap [("right", jsonInt int)])
  
  wrappedTypesAreSupported :: H.SpecWith ()
  wrappedTypesAreSupported = H.describe "Verify that nominal types are supported" $ do
    H.it "Nominal unions become single-attribute objects" $
      QC.property $ \() -> checkJsonCoder (TypeVariable testTypeUnionMonomorphicName)
        (Terms.inject testTypeUnionMonomorphicName $ Terms.field "bool" $ Terms.boolean True)
        (jsonMap [("bool", jsonBool True)])
  
    H.it "Nominal enums become single-attribute objects with empty-object values, and type annotations are transparent" $
      QC.property $ \() -> checkJsonCoder (TypeVariable testTypeComparisonName)
        (Terms.inject testTypeComparisonName $ Terms.field "equalTo" Terms.unit)
        (jsonMap [("equalTo", jsonMap [])])
  
  spec :: H.Spec
  spec = do
    literalTypeConstraintsAreRespected
    supportedTypesPassThrough
    unsupportedTypesAreTransformed
    -- TODO: restore
  --  wrappedTypesAreSupported
  
  checkJsonCoder :: Type -> Term -> Json.Value -> H.Expectation
  checkJsonCoder typ term node = case mstep of
      Nothing -> HL.assertFailure (traceSummary trace)
      Just step -> do
        shouldSucceedWith (coderEncode step term) node
        shouldSucceedWith (coderEncode step term >>= coderDecode step) term
    where
      FlowState mstep _ trace = unFlow (jsonCoder typ) testGraph emptyTrace
  
  jsonBool :: Bool -> Json.Value
  jsonBool = Json.ValueBoolean
  
  jsonFloat :: Double -> Json.Value
  jsonFloat = Json.ValueNumber
  
  jsonInt :: Integral i => i -> Json.Value
  jsonInt = Json.ValueNumber . bigintToBigfloat . fromIntegral
  
  jsonMap :: [(String, Json.Value)] -> Json.Value
  jsonMap = Json.ValueObject . M.fromList
  
  jsonNull :: Json.Value
  jsonNull = Json.ValueNull
  