finitary-optics/test/Main.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Data.Finitary.Optics (reindexed, tighter)
import Data.Int (Int16, Int8)
import Data.Word (Word8)
import Hedgehog ((===), discard, forAll)
import Hedgehog.Gen (bool, choice, int8, word8)
import Hedgehog.Range (constantBounded)
import Optics.AffineFold (preview)
import Optics.Getter (view)
import Optics.Iso (Iso')
import Optics.Prism (Prism')
import Optics.Review (review)
import Test.Hspec (describe, hspec, it)
import Test.Hspec.Hedgehog (hedgehog)

main :: IO ()
main = hspec $ do
  describe "tighter" $ do
    it "should follow the review-preview law" . hedgehog $ do
      x <- forAll . word8 $ constantBounded
      let t :: Prism' Int16 Word8 = tighter
      (preview t . review t $ x) === Just x
    it "should follow the preview-review law" . hedgehog $ do
      x <- forAll . choice $ [Left <$> bool, Right <$> int8 constantBounded]
      let t :: Prism' (Either Bool Int8) Word8 = tighter
      case preview t x of
        Nothing -> discard
        Just y -> review t y === x
    it "should preserve ordering via review" . hedgehog $ do
      x <- forAll . word8 $ constantBounded
      y <- forAll . word8 $ constantBounded
      let t :: Prism' Int16 Word8 = tighter
      compare x y === compare (review t x) (review t y)
    it "should preserve ordering via preview" . hedgehog $ do
      x <- forAll . choice $ [Left <$> bool, Right <$> int8 constantBounded]
      y <- forAll . choice $ [Left <$> bool, Right <$> int8 constantBounded]
      let t :: Prism' (Either Bool Int8) Word8 = tighter
      case (preview t x, preview t y) of
        (Just x', Just y') -> compare x y === compare x' y'
        _ -> discard
  describe "reindexed" $ do
    it "should follow the iso laws" . hedgehog $ do
      x <- forAll . word8 $ constantBounded
      let i :: Iso' Word8 Int8 = reindexed
      (review i . view i $ x) === x
    it "should preserve ordering" . hedgehog $ do
      x <- forAll . word8 $ constantBounded
      y <- forAll . word8 $ constantBounded
      let i :: Iso' Word8 Int8 = reindexed
      compare x y === compare (view i x) (view i y)