Laws.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Sv.Core.Laws (test_Laws) where

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Monoid (Last)
import Data.Profunctor (Profunctor (dimap))
import Data.Semigroupoid (Semigroupoid (o))
import qualified Data.Validation as V
import Data.Vector (Vector, fromList, toList)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (Arbitrary (arbitrary), CoArbitrary (coarbitrary), Gen, testProperty, oneof, listOf)

import Data.Sv.Decode.Type
import qualified Data.Sv.Decode.Core as D

test_Laws :: TestTree
test_Laws =
  testGroup "Laws"
    [ testGroup "Decode Semigroupoid" $ fmap (uncurry testProperty)
        [ ("Decode Semigroupoid associativity", decodeAssoc)
        ]
    ]

decodeAssoc :: Gen Bool
decodeAssoc = do
  dec1 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)
  dec2 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)
  dec3 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)
  v <- arbOut
  i <- arbOut
  let comp1 = (dec1 `o` dec2) `o` dec3
  let comp2 = dec1 `o` (dec2 `o` dec3)
  pure (eqDecode v i comp1 comp2)


eqDecode :: (Eq e, Eq a) => Vector s -> Ind -> Decode e s a -> Decode e s a -> Bool
eqDecode v i d e =
  D.runDecode d v i == D.runDecode e v i

decodeGen :: (CoArbitrary (In s), Arbitrary (Out a), Arbitrary (Out e)) => Gen (Decode e s a)
decodeGen =
  buildDecode <$> (unwrap <$> arbitrary)

unwrap :: (Input s -> Output e a) -> Vector s -> Ind -> (Validation e a, Last Bool, Ind)
unwrap = curry . dimap Input unwrapO

newtype Output e a =
  Output { unwrapO :: (Validation e a, Last Bool, Ind) }

newtype Input s = Input (Vector s, Ind)

newtype In a = In a
newtype Out a = Out { unout :: a }

coarbIn :: CoArbitrary (In a) => a -> Gen b -> Gen b
coarbIn = coarbitrary . In

arbOut :: Arbitrary (Out a) => Gen a
arbOut = unout <$> arbitrary

instance (Arbitrary (Out e), Arbitrary (Out a)) => Arbitrary (Output e a) where
  arbitrary =
    Output <$>
      ((,,) <$> oneof [V.Failure <$> arbOut, V.Success <$> arbOut]
          <*> arbitrary
          <*> (Ind <$> arbOut))

instance (CoArbitrary (In (Vector s)), CoArbitrary (In Ind)) => CoArbitrary (Input s) where
  coarbitrary (Input (v,i)) = coarbIn v . coarbIn i

instance Arbitrary (Out ByteString) where
  arbitrary = Out <$> (BS.pack <$> arbitrary)

instance CoArbitrary (In ByteString) where
  coarbitrary (In bs) = coarbitrary (BS.unpack bs)

instance Arbitrary (Out Ind) where
  arbitrary = Out . Ind <$> arbitrary

instance Arbitrary (Out Int) where
  arbitrary = Out <$> arbitrary

instance CoArbitrary (In s) => CoArbitrary (In (Vector s)) where
  coarbitrary (In v) = coarbitrary (In <$> toList v)

instance CoArbitrary (In Ind) where
  coarbitrary (In (Ind i)) = coarbitrary i

instance Arbitrary (Out e) => Arbitrary (Out (DecodeErrors e)) where
  arbitrary = Out . DecodeErrors <$> arbOut

instance Arbitrary (Out e) => Arbitrary (Out (NonEmpty e)) where
  arbitrary = Out <$> ((:|) <$> arbOut <*> arbOut)

instance Arbitrary (Out e) => Arbitrary (Out [e]) where
  arbitrary = Out <$> listOf arbOut

instance Arbitrary (Out e) => Arbitrary (Out (Vector e)) where
  arbitrary = Out . fromList <$> arbOut

instance Arbitrary (Out e) => Arbitrary (Out (DecodeError e)) where
  arbitrary = Out <$> oneof
    [ pure UnexpectedEndOfRow
    , ExpectedEndOfRow <$> arbOut
    , UnknownCategoricalValue <$> arbOut <*> arbOut
    , BadParse <$> arbOut
    , BadDecode <$> arbOut
    ]