mirror of
https://github.com/coot/free-category.git
synced 2024-09-11 14:17:30 +03:00
Added Show instances for Cat and C
This commit is contained in:
parent
074b57df8f
commit
1dc741964b
@ -25,3 +25,4 @@
|
||||
- `FreeEffCat` constructor as `Effect` and `lift` as `effect`
|
||||
- `liftCat` to `liftEffect`
|
||||
- `foldNatLift` to `foldNatEffCat`
|
||||
- Show instance of 'Cat' and 'C' via 'ListTr' (GHC >= 806)
|
||||
|
@ -1,16 +1,19 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
#endif
|
||||
|
||||
{-# OPTIONS_HADDOCK show-extensions #-}
|
||||
|
||||
@ -125,6 +128,18 @@ instance Category (Cat f) where
|
||||
Id . f = f
|
||||
f . Id = f
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
-- | Show instance via 'ListTr'
|
||||
--
|
||||
instance (forall x y. Show (f x y)) => Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#else
|
||||
-- | Blind show instance via 'ListTr'
|
||||
--
|
||||
instance Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#endif
|
||||
|
||||
arrCat :: forall (f :: k -> k -> *) a b.
|
||||
f a b
|
||||
-> Cat f a b
|
||||
@ -281,6 +296,18 @@ instance Category (C f) where
|
||||
C bc . C ab = C $ \k -> bc k . ab k
|
||||
{-# INLINE (.) #-}
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
-- | Show instance via 'ListTr'
|
||||
--
|
||||
instance (forall x y. Show (f x y)) => Show (C f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#else
|
||||
-- | Blind show instance via 'ListTr'
|
||||
--
|
||||
instance Show (C f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#endif
|
||||
|
||||
-- |
|
||||
-- Isomorphism from @'Cat'@ to @'C'@, which is a specialisation of
|
||||
-- @'hoistFreeH2'@.
|
||||
|
@ -317,7 +317,7 @@ toList c = go (hoistFreeH2 c)
|
||||
newtype ArbIntCat = ArbIntCat (Cat IntCat '() '())
|
||||
|
||||
instance Show ArbIntCat where
|
||||
show (ArbIntCat c) = show (toList c)
|
||||
show (ArbIntCat c) = show c
|
||||
|
||||
instance Arbitrary ArbIntCat where
|
||||
arbitrary = ArbIntCat . fromList <$> arbitrary
|
||||
@ -344,6 +344,9 @@ prop_associativity_Cat (ArbIntCat f0)
|
||||
|
||||
newtype ArbIntC = ArbIntC (C IntCat '() '())
|
||||
|
||||
instance Show ArbIntC where
|
||||
show (ArbIntC c) = show c
|
||||
|
||||
instance Arbitrary ArbIntC where
|
||||
arbitrary = ArbIntC . fromList <$> arbitrary
|
||||
shrink (ArbIntC c) =
|
||||
@ -351,16 +354,16 @@ instance Arbitrary ArbIntC where
|
||||
$ shrinkList (const [])
|
||||
$ toList c
|
||||
|
||||
prop_id_C :: Blind ArbIntC -> Bool
|
||||
prop_id_C (Blind (ArbIntC f)) =
|
||||
prop_id_C :: ArbIntC -> Bool
|
||||
prop_id_C (ArbIntC f) =
|
||||
prop_id (on (==) toList) f
|
||||
|
||||
prop_associativity_C
|
||||
:: Blind ArbIntC -> Blind ArbIntC -> Blind ArbIntC
|
||||
:: ArbIntC -> ArbIntC -> ArbIntC
|
||||
-> Bool
|
||||
prop_associativity_C (Blind (ArbIntC f0))
|
||||
(Blind (ArbIntC f1))
|
||||
(Blind (ArbIntC f2)) =
|
||||
prop_associativity_C (ArbIntC f0)
|
||||
(ArbIntC f1)
|
||||
(ArbIntC f2) =
|
||||
prop_associativity (on (==) toList) f0 f1 f2
|
||||
|
||||
--
|
||||
|
Loading…
Reference in New Issue
Block a user