ModelTest.hs

modelTest
    :: forall a b f g c.
    ( c a, c b
    , QC.Arbitrary (f b), Eq (g a)
    , Show (f a), Show (f b), Show (g a), Show (g b)
    , Functor f, Functor g
    )
    => (b -> a)
    -> Proxy c
    -> TestName
    -> (forall x. c x => f x -> g x)
    -> TestTree
modelTest b2a _ name f2g = testProperty name $ \fb ->
    let gb :: g b
        gb = f2g fb

        fa :: f a
        fa = fmap b2a fb

        ga :: g a
        ga = f2g fa

        ga' :: g a
        ga' = fmap b2a gb

        msg = unlines
            [ show fb                   ++ " --> " ++ show gb ++ " --> " ++ show ga'
            , map (const ' ') (show fb) ++ " --> " ++ show fa ++ " --> " ++ show ga
            ]
      
    in QC.counterexample msg $ ga' QC.=== ga

-------------------------------------------------------------------------------
-- Functor utilities
-------------------------------------------------------------------------------

mapAA :: (a -> b) -> Identity a -> Identity b
mapAA = coerce

mapAX :: (a -> x) -> Identity a -> Const x a
mapAX = coerce

mapAAX :: (a -> a -> x) -> V2 a -> Const x a
mapAAX f (V2 x y) = Const (f x y)

mapAAA :: (a -> a -> a) -> V2 a -> Identity a
mapAAA f (V2 x y) = Identity (f x y)

mapAXA :: (a -> x -> a) -> (x, a) -> Identity a
mapAXA f (x, a) = Identity (f a x)

mapAXY :: (a -> x -> y) -> (x, a) -> Const y a
mapAXY f (x, a) = Const (f a x)

data V2 a = V2 a a deriving (Eq, Show, Functor)

instance QC.Arbitrary a => QC.Arbitrary (V2 a) where
    arbitrary = liftA2 V2 QC.arbitrary QC.arbitrary