tagliatelle-0.9.0: test/Spec.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Main (main) where

import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.OpenApi qualified as OpenApi
import Data.Tagliatelle
import Data.Tagliatelle.Properties
import Data.Text (Text)
import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.Hedgehog (testProperty)

main :: IO ()
main =
  defaultMain $
    testGroup
      "Tagliatelle"
      [ codecsLawful,
        testGroup
          "Dependency Assumptions"
          [ aesonAssumptions
          ]
      ]

-- kvmapText relies on fromText and toText being monotonic
aesonAssumptions :: TestTree
aesonAssumptions =
  testGroup
    "aeson"
    [ testProperty "Key.fromText is monotonic" $ property $ do
        a <- forAll genText
        b <- forAll $ Gen.filter (>= a) genText
        assert (Key.fromText a <= Key.fromText b),
      testProperty "Key.toText is monotonic" $ property $ do
        a <- fmap Key.fromText $ forAll genText
        b <- forAll $ Gen.filter (>= a) $ fmap Key.fromText genText
        assert (Key.toText a <= Key.toText b)
    ]
  where
    genText = Gen.text (Range.linear 0 20) Gen.unicode

codecsLawful :: TestTree
codecsLawful =
  let s = 4
      r = Range.linear 3 20
      genInt = Gen.int64 (Range.linearFrom 0 minBound maxBound)
   in testGroup
        "Codecs are Lawful"
        [ -- Our test types:
          codecLawsBundle "TestProd" genTestProd,
          codecLawsBundle "TestCoprod" genTestCoprod,
          codecLawsBundle "TestRecursive" (genTestRecursive s),
          -- Compositions of them
          codecLawsBundle
            "(TestProd, TestEnum, TestProd)"
            ((,,) <$> genTestProd <*> genEnum <*> genTestProd),
          codecLawsBundle
            "[(TestProd, TestCoprod)]"
            (Gen.list r ((,) <$> genTestProd <*> genTestCoprod)),
          codecLawsBundle
            "Map Int TestRecursive"
            (Gen.map r ((,) <$> genInt <*> genTestRecursive s)),
          codecLawsBundle
            "Map Text TestCoprod"
            (Gen.map r ((,) <$> Gen.text r Gen.unicodeAll <*> genTestCoprod)),
          codecLawsBundle
            "[Map Int (TestProd, Map Text TestCoprod)]"
            ( Gen.list
                r
                ( Gen.map
                    r
                    ( (,)
                        <$> genInt
                        <*> ( (,)
                                <$> genTestProd
                                <*> (Gen.map r ((,) <$> Gen.text r Gen.unicodeAll <*> genTestCoprod))
                            )
                    )
                )
            )
        ]

data TestProd = TestProd
  { fieldInt :: Int,
    fieldText :: Text,
    fieldBool :: Bool,
    fieldFloat :: Float
  }
  deriving (Eq, Ord, Show)
  deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestProd

instance HasCodec TestProd where
  codec =
    prod "TestProd" $
      TestProd
        <$> field "fieldInt" fieldInt codec
        <*> field "fieldText" fieldText codec
        <*> field "fieldBool" fieldBool codec
        <*> field "fieldFloat" fieldFloat codec

genTestProd :: Gen TestProd
genTestProd =
  TestProd
    <$> Gen.int Range.linearBounded
    <*> Gen.text (Range.linear 3 25) Gen.alphaNum
    <*> Gen.bool
    <*> Gen.float (Range.linearFracFrom 0 (-1e35) 1e35)

data TestCoprod
  = TestCoprodString {coprodString :: String}
  | TestCoprodDouble {coprodDouble :: Double}
  deriving (Eq, Ord, Show)
  deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestCoprod

instance HasCodec TestCoprod where
  codec =
    coprod @"type"
      "TestCoprod"
      ( \case
          TestCoprodString {} -> stringCase
          TestCoprodDouble {} -> doubleCase
      )
      [stringCase, doubleCase]
    where
      stringCase = Tagged "string" $ TestCoprodString <$> field "val" coprodString codec
      doubleCase = Tagged "double" $ TestCoprodDouble <$> field "val" coprodDouble codec

genTestCoprod :: Gen TestCoprod
genTestCoprod =
  Gen.frequency
    [ (1, TestCoprodString <$> Gen.string (Range.linear 3 15) Gen.alphaNum),
      (1, TestCoprodDouble <$> Gen.double (Range.linearFracFrom 0 (-1e305) 1e305))
    ]

data TestRecursive
  = TestRecursiveBranch {left :: TestRecursive, right :: TestRecursive}
  | TestRecursiveLeaf {val :: TestProd}
  deriving (Eq, Ord, Show)
  deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestRecursive

instance HasCodec TestRecursive where
  codec =
    coprod @"type"
      "TestRecursive"
      ( \case
          TestRecursiveBranch {} -> branch
          TestRecursiveLeaf {} -> leaf
      )
      [branch, leaf]
    where
      branch = Tagged "branch" $ TestRecursiveBranch <$> field "left" left codec <*> field "right" right codec
      leaf = Tagged "leaf" $ TestRecursiveLeaf <$> field "val" val codec

genTestRecursive :: Int -> Gen TestRecursive
genTestRecursive d
  | d <= 0 = TestRecursiveLeaf <$> genTestProd
  | otherwise =
      Gen.frequency
        [ (3, TestRecursiveBranch <$> genTestRecursive (d - 1) <*> genTestRecursive (d - 1)),
          (1, TestRecursiveLeaf <$> genTestProd)
        ]

data TestEnum = One | Two | Three
  deriving (Eq, Ord, Show)
  deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestEnum

instance HasCodec TestEnum where
  codec = enum "TestEnum" [(One, "one"), (Two, "two"), (Three, "three")]

genEnum :: Gen TestEnum
genEnum = Gen.element [One, Two, Three]