alignment-0.2.0.1: test/Laws.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}

module Main (main) where

import Data.Alignment
import Data.Bifunctor (bimap)
import Data.Functor.Identity (Identity (..))
import qualified Data.IntMap as IntMap
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Vector as Vector
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import System.Exit (exitFailure, exitSuccess)
import System.IO (hSetEncoding, stderr, stdout, utf8)

-- * Generators

genList :: Gen a -> Gen [a]
genList = Gen.list (Range.linear 0 20)

genNonEmpty :: Gen a -> Gen (NonEmpty a)
genNonEmpty g = (:|) <$> g <*> genList g

genMaybe :: Gen a -> Gen (Maybe a)
genMaybe = Gen.maybe

genVector :: Gen a -> Gen (Vector.Vector a)
genVector = fmap Vector.fromList . genList

genSeq :: Gen a -> Gen (Seq.Seq a)
genSeq = fmap Seq.fromList . genList

genMap :: (Ord k) => Gen k -> Gen v -> Gen (Map.Map k v)
genMap genK genV = Map.fromList <$> genList ((,) <$> genK <*> genV)

genIntMap :: Gen v -> Gen (IntMap.IntMap v)
genIntMap genV = IntMap.fromList <$> genList ((,) <$> Gen.int (Range.linear 0 100) <*> genV)

genInt :: Gen Int
genInt = Gen.int (Range.linear (-100) 100)

genChar :: Gen Char
genChar = Gen.alpha

-- * Test properties

-- ** Functor laws for This

prop_functorIdentity_List :: Property
prop_functorIdentity_List = property $ do
  this <- forAll $ genThisListNonEmpty genInt genInt
  this === this

prop_functorComposition_List :: Property
prop_functorComposition_List = property $ do
  this <- forAll $ genThisListNonEmpty genInt genInt
  let f = (+ 1)
  let g = (* 2)
  fmap (f . g) this === fmap f (fmap g this)

-- ** Bifunctor laws for This

prop_bifunctorIdentity_List :: Property
prop_bifunctorIdentity_List = property $ do
  this <- forAll $ genThisListNonEmpty genInt genInt
  this === this

prop_bifunctorComposition_List :: Property
prop_bifunctorComposition_List = property $ do
  this <- forAll $ genThisListNonEmpty genInt genInt
  let f1 = (+ 1)
  let f2 = (* 2)
  let g1 = (+ 10)
  let g2 = (* 20)
  bimap (f1 . f2) (g1 . g2) this === bimap f1 g1 (bimap f2 g2 this)

-- ** Semialign laws - List

prop_semialignNaturality_List :: Property
prop_semialignNaturality_List = property $ do
  xs <- forAll $ genList genInt
  ys <- forAll $ genList genInt
  let f = (+ 1)
  let g = (* 2)
  semialignNaturality f g xs ys === True

prop_semialignSymmetry_List :: Property
prop_semialignSymmetry_List = property $ do
  xs <- forAll $ genList genInt
  ys <- forAll $ genList genInt
  semialignSymmetry xs ys === True

prop_semialignCoherence_List :: Property
prop_semialignCoherence_List = property $ do
  xs <- forAll $ genList genInt
  ys <- forAll $ genList genInt
  semialignCoherence xs ys === True

prop_semialignWithLaw_List :: Property
prop_semialignWithLaw_List = property $ do
  xs <- forAll $ genList genInt
  ys <- forAll $ genList genInt
  let g = (* 2)
      h = (* 3)
      f (a, b) = (g a, h b)
  semialignWithLaw f g h xs ys === True

-- ** Semialign laws - Maybe

prop_semialignNaturality_Maybe :: Property
prop_semialignNaturality_Maybe = property $ do
  xs <- forAll $ genMaybe genInt
  ys <- forAll $ genMaybe genInt
  let f = (+ 1)
  let g = (* 2)
  semialignNaturality f g xs ys === True

prop_semialignSymmetry_Maybe :: Property
prop_semialignSymmetry_Maybe = property $ do
  xs <- forAll $ genMaybe genInt
  ys <- forAll $ genMaybe genInt
  semialignSymmetry xs ys === True

prop_semialignCoherence_Maybe :: Property
prop_semialignCoherence_Maybe = property $ do
  xs <- forAll $ genMaybe genInt
  ys <- forAll $ genMaybe genInt
  semialignCoherence xs ys === True

-- ** Semialign laws - NonEmpty

prop_semialignNaturality_NonEmpty :: Property
prop_semialignNaturality_NonEmpty = property $ do
  xs <- forAll $ genNonEmpty genInt
  ys <- forAll $ genNonEmpty genInt
  let f = (+ 1)
  let g = (* 2)
  semialignNaturality f g xs ys === True

prop_semialignSymmetry_NonEmpty :: Property
prop_semialignSymmetry_NonEmpty = property $ do
  xs <- forAll $ genNonEmpty genInt
  ys <- forAll $ genNonEmpty genInt
  semialignSymmetry xs ys === True

prop_semialignCoherence_NonEmpty :: Property
prop_semialignCoherence_NonEmpty = property $ do
  xs <- forAll $ genNonEmpty genInt
  ys <- forAll $ genNonEmpty genInt
  semialignCoherence xs ys === True

-- ** Semialign laws - Vector

prop_semialignNaturality_Vector :: Property
prop_semialignNaturality_Vector = property $ do
  xs <- forAll $ genVector genInt
  ys <- forAll $ genVector genInt
  let f = (+ 1)
  let g = (* 2)
  semialignNaturality f g xs ys === True

prop_semialignSymmetry_Vector :: Property
prop_semialignSymmetry_Vector = property $ do
  xs <- forAll $ genVector genInt
  ys <- forAll $ genVector genInt
  semialignSymmetry xs ys === True

prop_semialignCoherence_Vector :: Property
prop_semialignCoherence_Vector = property $ do
  xs <- forAll $ genVector genInt
  ys <- forAll $ genVector genInt
  semialignCoherence xs ys === True

-- ** Semialign laws - Seq

prop_semialignNaturality_Seq :: Property
prop_semialignNaturality_Seq = property $ do
  xs <- forAll $ genSeq genInt
  ys <- forAll $ genSeq genInt
  let f = (+ 1)
  let g = (* 2)
  semialignNaturality f g xs ys === True

prop_semialignSymmetry_Seq :: Property
prop_semialignSymmetry_Seq = property $ do
  xs <- forAll $ genSeq genInt
  ys <- forAll $ genSeq genInt
  semialignSymmetry xs ys === True

prop_semialignCoherence_Seq :: Property
prop_semialignCoherence_Seq = property $ do
  xs <- forAll $ genSeq genInt
  ys <- forAll $ genSeq genInt
  semialignCoherence xs ys === True

-- ** Semialign laws - Map

-- Note: Map and IntMap do NOT satisfy the symmetry law when both sides
-- have disjoint keys (leftovers). When both have leftovers, left takes
-- precedence. This is a known limitation and why they don't have Unalign
-- instances. We still test naturality and coherence which do hold.

prop_semialignNaturality_Map :: Property
prop_semialignNaturality_Map = property $ do
  xs <- forAll $ genMap genInt genChar
  ys <- forAll $ genMap genInt genChar
  let f = toEnum . (+ 1) . fromEnum :: Char -> Char
  let g = toEnum . (+ 2) . fromEnum :: Char -> Char
  semialignNaturality f g xs ys === True

-- Skip symmetry test for Map - known to fail when both sides have disjoint keys
-- prop_semialignSymmetry_Map :: Property
-- prop_semialignSymmetry_Map = property $ do
--   xs <- forAll $ genMap genInt genChar
--   ys <- forAll $ genMap genInt genChar
--   semialignSymmetry xs ys === True

prop_semialignCoherence_Map :: Property
prop_semialignCoherence_Map = property $ do
  xs <- forAll $ genMap genInt genChar
  ys <- forAll $ genMap genInt genChar
  semialignCoherence xs ys === True

-- ** Semialign laws - IntMap

-- Note: IntMap, like Map, does NOT satisfy the symmetry law when both sides
-- have disjoint keys (leftovers). When both have leftovers, left takes
-- precedence. This is a known limitation and why they don't have Unalign
-- instances.

prop_semialignNaturality_IntMap :: Property
prop_semialignNaturality_IntMap = property $ do
  xs <- forAll $ genIntMap genChar
  ys <- forAll $ genIntMap genChar
  let f = toEnum . (+ 1) . fromEnum :: Char -> Char
  let g = toEnum . (+ 2) . fromEnum :: Char -> Char
  semialignNaturality f g xs ys === True

-- Skip symmetry test for IntMap - known to fail when both sides have disjoint keys
-- prop_semialignSymmetry_IntMap :: Property
-- prop_semialignSymmetry_IntMap = property $ do
--   xs <- forAll $ genIntMap genChar
--   ys <- forAll $ genIntMap genChar
--   semialignSymmetry xs ys === True

prop_semialignCoherence_IntMap :: Property
prop_semialignCoherence_IntMap = property $ do
  xs <- forAll $ genIntMap genChar
  ys <- forAll $ genIntMap genChar
  semialignCoherence xs ys === True

-- ** Align laws - List

prop_alignRightIdentity_List :: Property
prop_alignRightIdentity_List = property $ do
  xs <- forAll $ genList genInt
  alignRightIdentity xs ([] :: [Char]) === True

prop_alignLeftIdentity_List :: Property
prop_alignLeftIdentity_List = property $ do
  ys <- forAll $ genList genInt
  alignLeftIdentity ([] :: [Char]) ys === True

prop_alignEmpty_List :: Property
prop_alignEmpty_List = property $ do
  alignEmpty (undefined :: [Int]) (undefined :: [Int]) === True

-- ** Align laws - Maybe

prop_alignRightIdentity_Maybe :: Property
prop_alignRightIdentity_Maybe = property $ do
  xs <- forAll $ genMaybe genInt
  alignRightIdentity xs (Nothing :: Maybe Char) === True

prop_alignLeftIdentity_Maybe :: Property
prop_alignLeftIdentity_Maybe = property $ do
  ys <- forAll $ genMaybe genInt
  alignLeftIdentity (Nothing :: Maybe Char) ys === True

prop_alignEmpty_Maybe :: Property
prop_alignEmpty_Maybe = property $ do
  alignEmpty (undefined :: Maybe Int) (undefined :: Maybe Int) === True

-- ** Align laws - Vector

prop_alignRightIdentity_Vector :: Property
prop_alignRightIdentity_Vector = property $ do
  xs <- forAll $ genVector genInt
  alignRightIdentity xs (Vector.empty :: Vector.Vector Char) === True

prop_alignLeftIdentity_Vector :: Property
prop_alignLeftIdentity_Vector = property $ do
  ys <- forAll $ genVector genInt
  alignLeftIdentity (Vector.empty :: Vector.Vector Char) ys === True

prop_alignEmpty_Vector :: Property
prop_alignEmpty_Vector = property $ do
  alignEmpty (undefined :: Vector.Vector Int) (undefined :: Vector.Vector Int) === True

-- ** Align laws - Seq

prop_alignRightIdentity_Seq :: Property
prop_alignRightIdentity_Seq = property $ do
  xs <- forAll $ genSeq genInt
  alignRightIdentity xs (Seq.empty :: Seq.Seq Char) === True

prop_alignLeftIdentity_Seq :: Property
prop_alignLeftIdentity_Seq = property $ do
  ys <- forAll $ genSeq genInt
  alignLeftIdentity (Seq.empty :: Seq.Seq Char) ys === True

prop_alignEmpty_Seq :: Property
prop_alignEmpty_Seq = property $ do
  alignEmpty (undefined :: Seq.Seq Int) (undefined :: Seq.Seq Int) === True

-- ** Align laws - Map

prop_alignRightIdentity_Map :: Property
prop_alignRightIdentity_Map = property $ do
  xs <- forAll $ genMap genInt genChar
  alignRightIdentity xs (Map.empty :: Map.Map Int Char) === True

prop_alignLeftIdentity_Map :: Property
prop_alignLeftIdentity_Map = property $ do
  ys <- forAll $ genMap genInt genChar
  alignLeftIdentity (Map.empty :: Map.Map Int Char) ys === True

prop_alignEmpty_Map :: Property
prop_alignEmpty_Map = property $ do
  alignEmpty (undefined :: Map.Map Int Char) (undefined :: Map.Map Int Char) === True

-- ** Align laws - IntMap

prop_alignRightIdentity_IntMap :: Property
prop_alignRightIdentity_IntMap = property $ do
  xs <- forAll $ genIntMap genChar
  alignRightIdentity xs (IntMap.empty :: IntMap.IntMap Char) === True

prop_alignLeftIdentity_IntMap :: Property
prop_alignLeftIdentity_IntMap = property $ do
  ys <- forAll $ genIntMap genChar
  alignLeftIdentity (IntMap.empty :: IntMap.IntMap Char) ys === True

prop_alignEmpty_IntMap :: Property
prop_alignEmpty_IntMap = property $ do
  alignEmpty (undefined :: IntMap.IntMap Char) (undefined :: IntMap.IntMap Char) === True

-- ** Unalign laws - List

prop_unalignRoundtrip_List :: Property
prop_unalignRoundtrip_List = property $ do
  xs <- forAll $ genList genInt
  ys <- forAll $ genList genInt
  unalignRoundtrip xs ys === True

prop_unalignNaturality_List :: Property
prop_unalignNaturality_List = property $ do
  this <- forAll $ genThisListNonEmpty genInt genInt
  let f = (+ 1)
  let g = (* 2)
  unalignNaturality f g this === True

-- ** Unalign laws - Maybe

prop_unalignRoundtrip_Maybe :: Property
prop_unalignRoundtrip_Maybe = property $ do
  xs <- forAll $ genMaybe genInt
  ys <- forAll $ genMaybe genInt
  unalignRoundtrip xs ys === True

prop_unalignNaturality_Maybe :: Property
prop_unalignNaturality_Maybe = property $ do
  this <- forAll $ genThisMaybeIdentity genInt genInt
  let f = (+ 1)
  let g = (* 2)
  unalignNaturality f g this === True

-- ** Unalign laws - NonEmpty

prop_unalignRoundtrip_NonEmpty :: Property
prop_unalignRoundtrip_NonEmpty = property $ do
  xs <- forAll $ genNonEmpty genInt
  ys <- forAll $ genNonEmpty genInt
  unalignRoundtrip xs ys === True

prop_unalignNaturality_NonEmpty :: Property
prop_unalignNaturality_NonEmpty = property $ do
  this <- forAll $ genThisNonEmptyNonEmpty genInt genInt
  let f = (+ 1)
  let g = (* 2)
  unalignNaturality f g this === True

-- ** Unalign laws - Vector

prop_unalignRoundtrip_Vector :: Property
prop_unalignRoundtrip_Vector = property $ do
  xs <- forAll $ genVector genInt
  ys <- forAll $ genVector genInt
  unalignRoundtrip xs ys === True

prop_unalignNaturality_Vector :: Property
prop_unalignNaturality_Vector = property $ do
  this <- forAll $ genThisVectorNonEmpty genInt genInt
  let f = (+ 1)
  let g = (* 2)
  unalignNaturality f g this === True

-- ** Unalign laws - Seq

prop_unalignRoundtrip_Seq :: Property
prop_unalignRoundtrip_Seq = property $ do
  xs <- forAll $ genSeq genInt
  ys <- forAll $ genSeq genInt
  unalignRoundtrip xs ys === True

prop_unalignNaturality_Seq :: Property
prop_unalignNaturality_Seq = property $ do
  this <- forAll $ genThisSeqNonEmpty genInt genInt
  let f = (+ 1)
  let g = (* 2)
  unalignNaturality f g this === True

-- * Helper generators

genThisListNonEmpty :: Gen a -> Gen b -> Gen (This [] NonEmpty a b)
genThisListNonEmpty genA genB = Gen.choice [viaAlign, withLeftover, withRightover, justPairs]
  where
    viaAlign = do
      as <- genList genA
      bs <- genList genB
      return $ align as bs
    withLeftover = do
      pairs <- genList ((,) <$> genA <*> genB)
      leftover <- genNonEmpty genA
      return $ This pairs (Just (Left leftover))
    withRightover = do
      pairs <- genList ((,) <$> genA <*> genB)
      rightover <- genNonEmpty genB
      return $ This pairs (Just (Right rightover))
    justPairs = do
      pairs <- genList ((,) <$> genA <*> genB)
      return $ This pairs Nothing

genThisMaybeIdentity :: Gen a -> Gen b -> Gen (This Maybe Identity a b)
genThisMaybeIdentity genA genB = Gen.choice [viaAlign, withLeft, withRight, justPairs, empty]
  where
    viaAlign = do
      ma <- genMaybe genA
      mb <- genMaybe genB
      return $ align ma mb
    withLeft = do
      a <- genA
      return $ This Nothing (Just (Left (Identity a)))
    withRight = do
      b <- genB
      return $ This Nothing (Just (Right (Identity b)))
    justPairs = do
      pair <- (,) <$> genA <*> genB
      return $ This (Just pair) Nothing
    empty = return $ This Nothing Nothing

genThisNonEmptyNonEmpty :: Gen a -> Gen b -> Gen (This NonEmpty NonEmpty a b)
genThisNonEmptyNonEmpty genA genB = Gen.choice [viaAlign, withLeftover, withRightover, justPairs]
  where
    viaAlign = do
      as <- genNonEmpty genA
      bs <- genNonEmpty genB
      return $ align as bs
    withLeftover = do
      pairs <- genNonEmpty ((,) <$> genA <*> genB)
      leftover <- genNonEmpty genA
      return $ This pairs (Just (Left leftover))
    withRightover = do
      pairs <- genNonEmpty ((,) <$> genA <*> genB)
      rightover <- genNonEmpty genB
      return $ This pairs (Just (Right rightover))
    justPairs = do
      pairs <- genNonEmpty ((,) <$> genA <*> genB)
      return $ This pairs Nothing

genThisVectorNonEmpty :: Gen a -> Gen b -> Gen (This Vector.Vector NonEmpty a b)
genThisVectorNonEmpty genA genB = Gen.choice [viaAlign, withLeftover, withRightover, justPairs]
  where
    viaAlign = do
      as <- genVector genA
      bs <- genVector genB
      return $ align as bs
    withLeftover = do
      pairs <- genVector ((,) <$> genA <*> genB)
      leftover <- genNonEmpty genA
      return $ This pairs (Just (Left leftover))
    withRightover = do
      pairs <- genVector ((,) <$> genA <*> genB)
      rightover <- genNonEmpty genB
      return $ This pairs (Just (Right rightover))
    justPairs = do
      pairs <- genVector ((,) <$> genA <*> genB)
      return $ This pairs Nothing

genThisSeqNonEmpty :: Gen a -> Gen b -> Gen (This Seq.Seq NonEmpty a b)
genThisSeqNonEmpty genA genB = Gen.choice [viaAlign, withLeftover, withRightover, justPairs]
  where
    viaAlign = do
      as <- genSeq genA
      bs <- genSeq genB
      return $ align as bs
    withLeftover = do
      pairs <- genSeq ((,) <$> genA <*> genB)
      leftover <- genNonEmpty genA
      return $ This pairs (Just (Left leftover))
    withRightover = do
      pairs <- genSeq ((,) <$> genA <*> genB)
      rightover <- genNonEmpty genB
      return $ This pairs (Just (Right rightover))
    justPairs = do
      pairs <- genSeq ((,) <$> genA <*> genB)
      return $ This pairs Nothing

-- * Main test runner

main :: IO ()
main = do
  hSetEncoding stdout utf8
  hSetEncoding stderr utf8

  results <-
    sequence
      [ checkGroup
          "Functor laws - This"
          [ ("identity (List)", prop_functorIdentity_List),
            ("composition (List)", prop_functorComposition_List)
          ],
        checkGroup
          "Bifunctor laws - This"
          [ ("identity (List)", prop_bifunctorIdentity_List),
            ("composition (List)", prop_bifunctorComposition_List)
          ],
        checkGroup
          "Semialign laws - List"
          [ ("naturality", prop_semialignNaturality_List),
            ("symmetry", prop_semialignSymmetry_List),
            ("coherence", prop_semialignCoherence_List),
            ("alignWith", prop_semialignWithLaw_List)
          ],
        checkGroup
          "Semialign laws - Maybe"
          [ ("naturality", prop_semialignNaturality_Maybe),
            ("symmetry", prop_semialignSymmetry_Maybe),
            ("coherence", prop_semialignCoherence_Maybe)
          ],
        checkGroup
          "Semialign laws - NonEmpty"
          [ ("naturality", prop_semialignNaturality_NonEmpty),
            ("symmetry", prop_semialignSymmetry_NonEmpty),
            ("coherence", prop_semialignCoherence_NonEmpty)
          ],
        checkGroup
          "Semialign laws - Vector"
          [ ("naturality", prop_semialignNaturality_Vector),
            ("symmetry", prop_semialignSymmetry_Vector),
            ("coherence", prop_semialignCoherence_Vector)
          ],
        checkGroup
          "Semialign laws - Seq"
          [ ("naturality", prop_semialignNaturality_Seq),
            ("symmetry", prop_semialignSymmetry_Seq),
            ("coherence", prop_semialignCoherence_Seq)
          ],
        checkGroup
          "Semialign laws - Map"
          [ ("naturality", prop_semialignNaturality_Map),
            -- symmetry skipped - known to fail for Map with disjoint keys
            ("coherence", prop_semialignCoherence_Map)
          ],
        checkGroup
          "Semialign laws - IntMap"
          [ ("naturality", prop_semialignNaturality_IntMap),
            -- symmetry skipped - known to fail for IntMap with disjoint keys
            ("coherence", prop_semialignCoherence_IntMap)
          ],
        checkGroup
          "Align laws - List"
          [ ("right identity", prop_alignRightIdentity_List),
            ("left identity", prop_alignLeftIdentity_List),
            ("empty", prop_alignEmpty_List)
          ],
        checkGroup
          "Align laws - Maybe"
          [ ("right identity", prop_alignRightIdentity_Maybe),
            ("left identity", prop_alignLeftIdentity_Maybe),
            ("empty", prop_alignEmpty_Maybe)
          ],
        checkGroup
          "Align laws - Vector"
          [ ("right identity", prop_alignRightIdentity_Vector),
            ("left identity", prop_alignLeftIdentity_Vector),
            ("empty", prop_alignEmpty_Vector)
          ],
        checkGroup
          "Align laws - Seq"
          [ ("right identity", prop_alignRightIdentity_Seq),
            ("left identity", prop_alignLeftIdentity_Seq),
            ("empty", prop_alignEmpty_Seq)
          ],
        checkGroup
          "Align laws - Map"
          [ ("right identity", prop_alignRightIdentity_Map),
            ("left identity", prop_alignLeftIdentity_Map),
            ("empty", prop_alignEmpty_Map)
          ],
        checkGroup
          "Align laws - IntMap"
          [ ("right identity", prop_alignRightIdentity_IntMap),
            ("left identity", prop_alignLeftIdentity_IntMap),
            ("empty", prop_alignEmpty_IntMap)
          ],
        checkGroup
          "Unalign laws - List"
          [ ("roundtrip", prop_unalignRoundtrip_List),
            ("naturality", prop_unalignNaturality_List)
          ],
        checkGroup
          "Unalign laws - Maybe"
          [ ("roundtrip", prop_unalignRoundtrip_Maybe),
            ("naturality", prop_unalignNaturality_Maybe)
          ],
        checkGroup
          "Unalign laws - NonEmpty"
          [ ("roundtrip", prop_unalignRoundtrip_NonEmpty),
            ("naturality", prop_unalignNaturality_NonEmpty)
          ],
        checkGroup
          "Unalign laws - Vector"
          [ ("roundtrip", prop_unalignRoundtrip_Vector),
            ("naturality", prop_unalignNaturality_Vector)
          ],
        checkGroup
          "Unalign laws - Seq"
          [ ("roundtrip", prop_unalignRoundtrip_Seq),
            ("naturality", prop_unalignNaturality_Seq)
          ]
      ]

  if and results
    then exitSuccess
    else exitFailure

checkGroup :: String -> [(String, Property)] -> IO Bool
checkGroup grpName props = do
  putStrLn $ "\n━━━ " ++ grpName ++ " ━━━"
  results <- mapM checkProp props
  return $ and results

checkProp :: (String, Property) -> IO Bool
checkProp (name, prop) = do
  putStrLn $ "  • " ++ name
  check prop