Added Show instances for Cat and C

ChangeLog.md

@@ -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)

src/Control/Category/Free.hs

@@ -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'@.

test/Test/Cat.hs

@@ -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
 
 --