1 files changed, 63 insertions, 4 deletions
diff --git a/src/Data/Array/Nested/Internal/Shape.hs b/src/Data/Array/Nested/Internal/Shape.hs
index 878ea7e..82b7966 100644
--- a/src/Data/Array/Nested/Internal/Shape.hs
+++ b/src/Data/Array/Nested/Internal/Shape.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -25,16 +26,19 @@
 {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 module Data.Array.Nested.Internal.Shape where
 
+import Control.DeepSeq (NFData (..))
 import Data.Array.Shape qualified as O
 import Data.Array.Mixed.Types
 import Data.Coerce (coerce)
 import Data.Foldable qualified as Foldable
 import Data.Functor.Const
+import Data.Functor.Product qualified as Fun
 import Data.Kind (Type, Constraint)
 import Data.Monoid (Sum(..))
 import Data.Proxy
 import Data.Type.Equality
 import GHC.Exts (withDict)
+import GHC.Generics (Generic)
 import GHC.IsList (IsList)
 import GHC.IsList qualified as IsList
 import GHC.TypeLits
@@ -59,6 +63,10 @@ infixr 3 :::
 instance Show i => Show (ListR n i) where
   showsPrec _ = listrShow shows
 
+instance NFData i => NFData (ListR n i) where
+  rnf ZR = ()
+  rnf (x ::: l) = rnf x `seq` rnf l
+
 data UnconsListRRes i n1 =
   forall n. (n + 1 ~ n1) => UnconsListRRes (ListR n i) i
 listrUncons :: ListR n1 i -> Maybe (UnconsListRRes i n1)
@@ -128,6 +136,18 @@ listrIndex SZ (x ::: _) = x
 listrIndex (SS i) (_ ::: xs) | Refl <- lemLeqSuccSucc (Proxy @k) (Proxy @n) = listrIndex i xs
 listrIndex _ ZR = error "k + 1 <= 0"
 
+listrZip :: ListR n i -> ListR n j -> ListR n (i, j)
+listrZip ZR ZR = ZR
+listrZip (i ::: irest) (j ::: jrest) = (i, j) ::: listrZip irest jrest
+listrZip _ _ = error "listrZip: impossible pattern needlessly required"
+
+listrZipWith :: (i -> j -> k) -> ListR n i -> ListR n j -> ListR n k
+listrZipWith _ ZR ZR = ZR
+listrZipWith f (i ::: irest) (j ::: jrest) =
+  f i j ::: listrZipWith f irest jrest
+listrZipWith _ _ _ =
+  error "listrZipWith: impossible pattern needlessly required"
+
 listrPermutePrefix :: forall i n. [Int] -> ListR n i -> ListR n i
 listrPermutePrefix = \perm sh ->
   listrFromList perm $ \sperm ->
@@ -157,7 +177,7 @@ listrPermutePrefix = \perm sh ->
 type role IxR nominal representational
 type IxR :: Nat -> Type -> Type
 newtype IxR n i = IxR (ListR n i)
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
   deriving newtype (Functor, Foldable)
 
 pattern ZIR :: forall n i. () => n ~ 0 => IxR n i
@@ -178,6 +198,8 @@ type IIxR n = IxR n Int
 instance Show i => Show (IxR n i) where
   showsPrec _ (IxR l) = listrShow shows l
 
+instance NFData i => NFData (IxR sh i)
+
 ixrLength :: IxR sh i -> Int
 ixrLength (IxR l) = listrLength l
 
@@ -213,6 +235,12 @@ ixrLast (IxR list) = listrLast list
 ixrAppend :: forall n m i. IxR n i -> IxR m i -> IxR (n + m) i
 ixrAppend = coerce (listrAppend @_ @i)
 
+ixrZip :: IxR n i -> IxR n j -> IxR n (i, j)
+ixrZip (IxR l1) (IxR l2) = IxR $ listrZip l1 l2
+
+ixrZipWith :: (i -> j -> k) -> IxR n i -> IxR n j -> IxR n k
+ixrZipWith f (IxR l1) (IxR l2) = IxR $ listrZipWith f l1 l2
+
 ixrPermutePrefix :: forall n i. [Int] -> IxR n i -> IxR n i
 ixrPermutePrefix = coerce (listrPermutePrefix @i)
 
@@ -220,7 +248,7 @@ ixrPermutePrefix = coerce (listrPermutePrefix @i)
 type role ShR nominal representational
 type ShR :: Nat -> Type -> Type
 newtype ShR n i = ShR (ListR n i)
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
   deriving newtype (Functor, Foldable)
 
 pattern ZSR :: forall n i. () => n ~ 0 => ShR n i
@@ -241,6 +269,8 @@ type IShR n = ShR n Int
 instance Show i => Show (ShR n i) where
   showsPrec _ (ShR l) = listrShow shows l
 
+instance NFData i => NFData (ShR sh i)
+
 shCvtXR' :: forall n. IShX (Replicate n Nothing) -> IShR n
 shCvtXR' ZSX =
   castWith (subst2 (unsafeCoerceRefl :: 0 :~: n))
@@ -346,6 +376,10 @@ infixr 3 ::$
 instance (forall n. Show (f n)) => Show (ListS sh f) where
   showsPrec _ = listsShow shows
 
+instance (forall m. NFData (f m)) => NFData (ListS n f) where
+  rnf ZS = ()
+  rnf (x ::$ l) = rnf x `seq` rnf l
+
 data UnconsListSRes f sh1 =
   forall n sh. (KnownNat n, n : sh ~ sh1) => UnconsListSRes (ListS sh f) (f n)
 listsUncons :: ListS sh1 f -> Maybe (UnconsListSRes f sh1)
@@ -419,6 +453,17 @@ listsAppend :: ListS sh f -> ListS sh' f -> ListS (sh ++ sh') f
 listsAppend ZS idx' = idx'
 listsAppend (i ::$ idx) idx' = i ::$ listsAppend idx idx'
 
+listsZip :: ListS sh f -> ListS sh g -> ListS sh (Fun.Product f g)
+listsZip ZS ZS = ZS
+listsZip (i ::$ is) (j ::$ js) =
+  Fun.Pair i j ::$ listsZip is js
+
+listsZipWith :: (forall a. f a -> g a -> h a) -> ListS sh f -> ListS sh g
+             -> ListS sh h
+listsZipWith _ ZS ZS = ZS
+listsZipWith f (i ::$ is) (j ::$ js) =
+  f i j ::$ listsZipWith f is js
+
 listsTakeLenPerm :: forall f is sh. Perm is -> ListS sh f -> ListS (TakeLen is sh) f
 listsTakeLenPerm PNil _ = ZS
 listsTakeLenPerm (_ `PCons` is) (n ::$ sh) = n ::$ listsTakeLenPerm is sh
@@ -454,7 +499,7 @@ listsPermutePrefix perm sh = listsAppend (listsPermute perm (listsTakeLenPerm pe
 type role IxS nominal representational
 type IxS :: [Nat] -> Type -> Type
 newtype IxS sh i = IxS (ListS sh (Const i))
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
 
 pattern ZIS :: forall sh i. () => sh ~ '[] => IxS sh i
 pattern ZIS = IxS ZS
@@ -480,6 +525,8 @@ instance Functor (IxS sh) where
 instance Foldable (IxS sh) where
   foldMap f (IxS l) = listsFold (f . getConst) l
 
+instance NFData i => NFData (IxS sh i)
+
 ixsLength :: IxS sh i -> Int
 ixsLength (IxS l) = listsLength l
 
@@ -513,6 +560,14 @@ ixsLast (IxS list) = getConst (listsLast list)
 ixsAppend :: forall sh sh' i. IxS sh i -> IxS sh' i -> IxS (sh ++ sh') i
 ixsAppend = coerce (listsAppend @_ @(Const i))
 
+ixsZip :: IxS n i -> IxS n j -> IxS n (i, j)
+ixsZip ZIS ZIS = ZIS
+ixsZip (i :.$ is) (j :.$ js) = (i, j) :.$ ixsZip is js
+
+ixsZipWith :: (i -> j -> k) -> IxS n i -> IxS n j -> IxS n k
+ixsZipWith _ ZIS ZIS = ZIS
+ixsZipWith f (i :.$ is) (j :.$ js) = f i j :.$ ixsZipWith f is js
+
 ixsPermutePrefix :: forall i is sh. Perm is -> IxS sh i -> IxS (PermutePrefix is sh) i
 ixsPermutePrefix = coerce (listsPermutePrefix @(Const i))
 
@@ -524,7 +579,7 @@ ixsPermutePrefix = coerce (listsPermutePrefix @(Const i))
 type role ShS nominal
 type ShS :: [Nat] -> Type
 newtype ShS sh = ShS (ListS sh SNat)
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
 
 pattern ZSS :: forall sh. () => sh ~ '[] => ShS sh
 pattern ZSS = ShS ZS
@@ -543,6 +598,10 @@ infixr 3 :$$
 instance Show (ShS sh) where
   showsPrec _ (ShS l) = listsShow (shows . fromSNat) l
 
+instance NFData (ShS sh) where
+  rnf (ShS ZS) = ()
+  rnf (ShS (SNat ::$ l)) = rnf (ShS l)
+
 instance TestEquality ShS where
   testEquality (ShS l1) (ShS l2) = listsEqType l1 l2