From 2a1ebc8ccf1978fa91e5ac808a0bebafe8a0882d Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sat, 18 May 2024 21:49:48 +0200
Subject: Custom Show instances for list-like output

---
 src/Data/Array/Nested/Internal.hs | 46 ++++++++++++++++++++++++++++++++-------
 1 file changed, 38 insertions(+), 8 deletions(-)

(limited to 'src/Data/Array/Nested')

diff --git a/src/Data/Array/Nested/Internal.hs b/src/Data/Array/Nested/Internal.hs
index cf90240..c66bd07 100644
--- a/src/Data/Array/Nested/Internal.hs
+++ b/src/Data/Array/Nested/Internal.hs
@@ -192,25 +192,34 @@ type ListR :: Nat -> Type -> Type
 data ListR n i where
   ZR :: ListR 0 i
   (:::) :: forall n {i}. i -> ListR n i -> ListR (n + 1) i
-deriving instance Show i => Show (ListR n i)
 deriving instance Eq i => Eq (ListR n i)
 deriving instance Ord i => Ord (ListR n i)
 deriving instance Functor (ListR n)
 deriving instance Foldable (ListR n)
 infixr 3 :::
 
+instance Show i => Show (ListR n i) where
+  showsPrec _ = showListR shows
+
 data UnconsListRRes i n1 =
   forall n. (n + 1 ~ n1) => UnconsListRRes (ListR n i) i
 unconsListR :: ListR n1 i -> Maybe (UnconsListRRes i n1)
 unconsListR (i ::: sh') = Just (UnconsListRRes sh' i)
 unconsListR ZR = Nothing
 
+showListR :: forall sh i. (i -> ShowS) -> ListR sh i -> ShowS
+showListR f l = go "[" l . showString "]"
+  where
+    go :: String -> ListR sh' i -> ShowS
+    go _ ZR = id
+    go prefix (x ::: xs) = showString prefix . f x . go "," xs
+
 
 -- | An index into a rank-typed array.
 type role IxR nominal representational
 type IxR :: Nat -> Type -> Type
 newtype IxR n i = IxR (ListR n i)
-  deriving (Show, Eq, Ord)
+  deriving (Eq, Ord)
   deriving newtype (Functor, Foldable)
 
 pattern ZIR :: forall n i. () => n ~ 0 => IxR n i
@@ -228,15 +237,16 @@ infixr 3 :.:
 
 type IIxR n = IxR n Int
 
+instance Show i => Show (IxR n i) where
+  showsPrec _ (IxR l) = showListR shows l
+
 
 type role ShR nominal representational
 type ShR :: Nat -> Type -> Type
 newtype ShR n i = ShR (ListR n i)
-  deriving (Show, Eq, Ord)
+  deriving (Eq, Ord)
   deriving newtype (Functor, Foldable)
 
-type IShR n = ShR n Int
-
 pattern ZSR :: forall n i. () => n ~ 0 => ShR n i
 pattern ZSR = ShR ZR
 
@@ -250,17 +260,24 @@ infixr 3 :$:
 
 {-# COMPLETE ZSR, (:$:) #-}
 
+type IShR n = ShR n Int
+
+instance Show i => Show (ShR n i) where
+  showsPrec _ (ShR l) = showListR shows l
+
 
 type role ListS nominal representational
 type ListS :: [Nat] -> (Nat -> Type) -> Type
 data ListS sh f where
   ZS :: ListS '[] f
   (::$) :: forall n sh {f}. KnownNat n => f n -> ListS sh f -> ListS (n : sh) f
-deriving instance (forall n. Show (f n)) => Show (ListS sh f)
 deriving instance (forall n. Eq (f n)) => Eq (ListS sh f)
 deriving instance (forall n. Ord (f n)) => Ord (ListS sh f)
 infixr 3 ::$
 
+instance (forall n. Show (f n)) => Show (ListS sh f) where
+  showsPrec _ = showListS shows
+
 data UnconsListSRes f sh1 =
   forall n sh. (KnownNat n, n : sh ~ sh1) => UnconsListSRes (ListS sh f) (f n)
 unconsListS :: ListS sh1 f -> Maybe (UnconsListSRes f sh1)
@@ -275,6 +292,13 @@ foldListS :: Monoid m => (forall n. f n -> m) -> ListS sh f -> m
 foldListS _ ZS = mempty
 foldListS f (x ::$ xs) = f x <> foldListS f xs
 
+showListS :: forall sh f. (forall n. f n -> ShowS) -> ListS sh f -> ShowS
+showListS f l = go "[" l . showString "]"
+  where
+    go :: String -> ListS sh' f -> ShowS
+    go _ ZS = id
+    go prefix (x ::$ xs) = showString prefix . f x . go "," xs
+
 
 -- | An index into a shape-typed array.
 --
@@ -285,7 +309,7 @@ foldListS f (x ::$ xs) = f x <> foldListS f xs
 type role IxS nominal representational
 type IxS :: [Nat] -> Type -> Type
 newtype IxS sh i = IxS (ListS sh (Const i))
-  deriving (Show, Eq, Ord)
+  deriving (Eq, Ord)
 
 pattern ZIS :: forall sh i. () => sh ~ '[] => IxS sh i
 pattern ZIS = IxS ZS
@@ -302,6 +326,9 @@ infixr 3 :.$
 
 type IIxS sh = IxS sh Int
 
+instance Show i => Show (IxS sh i) where
+  showsPrec _ (IxS l) = showListS (\(Const i) -> shows i) l
+
 instance Functor (IxS sh) where
   fmap f (IxS l) = IxS (fmapListS (Const . f . getConst) l)
 
@@ -313,7 +340,7 @@ instance Foldable (IxS sh) where
 type role ShS nominal
 type ShS :: [Nat] -> Type
 newtype ShS sh = ShS (ListS sh SNat)
-  deriving (Show, Eq, Ord)
+  deriving (Eq, Ord)
 
 pattern ZSS :: forall sh. () => sh ~ '[] => ShS sh
 pattern ZSS = ShS ZS
@@ -329,6 +356,9 @@ infixr 3 :$$
 
 {-# COMPLETE ZSS, (:$$) #-}
 
+instance Show (ShS sh) where
+  showsPrec _ (ShS l) = showListS (shows . fromSNat) l
+
 
 -- | Wrapper type used as a tag to attach instances on. The instances on arrays
 -- of @'Primitive' a@ are more polymorphic than the direct instances for arrays
-- 
cgit v1.2.3-70-g09d2