Make List?, except ListH, less general

1 files changed, 57 insertions, 95 deletions

diff --git a/src/Data/Array/Nested/Mixed/Shape.hs b/src/Data/Array/Nested/Mixed/Shape.hs
index 802c71e..c707f18 100644
--- a/src/Data/Array/Nested/Mixed/Shape.hs
+++ b/src/Data/Array/Nested/Mixed/Shape.hs
@@ -32,8 +32,6 @@ import Control.DeepSeq (NFData(..))
 import Data.Bifunctor (first)
 import Data.Coerce
 import Data.Foldable qualified as Foldable
-import Data.Functor.Const
-import Data.Functor.Product
 import Data.Kind (Constraint, Type)
 import Data.Monoid (Sum(..))
 import Data.Proxy
@@ -59,126 +57,104 @@ type family Rank sh where
 -- * Mixed lists to be used IxX and shaped and ranked lists and indexes
 
 type role ListX nominal representational
-type ListX :: [Maybe Nat] -> (Maybe Nat -> Type) -> Type
-data ListX sh f where
-  ZX :: ListX '[] f
-  (::%) :: forall n sh {f}. f n -> ListX sh f -> ListX (n : sh) f
-deriving instance (forall n. Eq (f n)) => Eq (ListX sh f)
-deriving instance (forall n. Ord (f n)) => Ord (ListX sh f)
+type ListX :: [Maybe Nat] -> Type -> Type
+data ListX sh i where
+  ZX :: ListX '[] i
+  (::%) :: forall n sh {i}. i -> ListX sh i -> ListX (n : sh) i
+deriving instance Eq i => Eq (ListX sh i)
+deriving instance Ord i => Ord (ListX sh i)
 infixr 3 ::%
 
 #ifdef OXAR_DEFAULT_SHOW_INSTANCES
-deriving instance (forall n. Show (f n)) => Show (ListX sh f)
+deriving instance Show i => Show (ListX sh i)
 #else
-instance (forall n. Show (f n)) => Show (ListX sh f) where
+instance Show i => Show (ListX sh i) where
   showsPrec _ = listxShow shows
 #endif
 
-instance (forall n. NFData (f n)) => NFData (ListX sh f) where
+instance NFData i => NFData (ListX sh i) where
   rnf ZX = ()
   rnf (x ::% l) = rnf x `seq` rnf l
 
-data UnconsListXRes f sh1 =
-  forall n sh. (n : sh ~ sh1) => UnconsListXRes (ListX sh f) (f n)
+data UnconsListXRes i sh1 =
+  forall n sh. (n : sh ~ sh1) => UnconsListXRes (ListX sh i) i
 listxUncons :: ListX sh1 f -> Maybe (UnconsListXRes f sh1)
 listxUncons (i ::% shl') = Just (UnconsListXRes shl' i)
 listxUncons ZX = Nothing
 
--- | This checks only whether the types are equal; if the elements of the list
--- are not singletons, their values may still differ. This corresponds to
--- 'testEquality', except on the penultimate type parameter.
-listxEqType :: TestEquality f => ListX sh f -> ListX sh' f -> Maybe (sh :~: sh')
-listxEqType ZX ZX = Just Refl
-listxEqType (n ::% sh) (m ::% sh')
-  | Just Refl <- testEquality n m
-  , Just Refl <- listxEqType sh sh'
-  = Just Refl
-listxEqType _ _ = Nothing
-
--- | This checks whether the two lists actually contain equal values. This is
--- more than 'testEquality', and corresponds to @geq@ from @Data.GADT.Compare@
--- in the @some@ package (except on the penultimate type parameter).
-listxEqual :: (TestEquality f, forall n. Eq (f n)) => ListX sh f -> ListX sh' f -> Maybe (sh :~: sh')
-listxEqual ZX ZX = Just Refl
-listxEqual (n ::% sh) (m ::% sh')
-  | Just Refl <- testEquality n m
-  , n == m
-  , Just Refl <- listxEqual sh sh'
-  = Just Refl
-listxEqual _ _ = Nothing
-
-{-# INLINE listxFmap #-}
-listxFmap :: (forall n. f n -> g n) -> ListX sh f -> ListX sh g
-listxFmap _ ZX = ZX
-listxFmap f (x ::% xs) = f x ::% listxFmap f xs
+instance Functor (ListX l) where
+  {-# INLINE fmap #-}
+  fmap _ ZX = ZX
+  fmap f (x ::% xs) = f x ::% fmap f xs
 
-{-# INLINE listxFoldMap #-}
-listxFoldMap :: Monoid m => (forall n. f n -> m) -> ListX sh f -> m
-listxFoldMap _ ZX = mempty
-listxFoldMap f (x ::% xs) = f x <> listxFoldMap f xs
+instance Foldable (ListX l) where
+  {-# INLINE foldMap #-}
+  foldMap _ ZX = mempty
+  foldMap f (x ::% xs) = f x <> foldMap f xs
+  {-# INLINE foldr #-}
+  foldr _ z ZX = z
+  foldr f z (x ::% xs) = f x (foldr f z xs)
+  toList = listxToList
+  null ZX = False
+  null _ = True
 
-listxLength :: ListX sh f -> Int
-listxLength = getSum . listxFoldMap (\_ -> Sum 1)
+listxLength :: ListX sh i -> Int
+listxLength = length
 
-listxRank :: ListX sh f -> SNat (Rank sh)
+listxRank :: ListX sh i -> SNat (Rank sh)
 listxRank ZX = SNat
 listxRank (_ ::% l) | SNat <- listxRank l = SNat
 
 {-# INLINE listxShow #-}
-listxShow :: forall sh f. (forall n. f n -> ShowS) -> ListX sh f -> ShowS
+listxShow :: forall sh i. (i -> ShowS) -> ListX sh i -> ShowS
 listxShow f l = showString "[" . go "" l . showString "]"
   where
-    go :: String -> ListX sh' f -> ShowS
+    go :: String -> ListX sh' i -> ShowS
     go _ ZX = id
     go prefix (x ::% xs) = showString prefix . f x . go "," xs
 
-listxFromList :: StaticShX sh -> [i] -> ListX sh (Const i)
+listxFromList :: StaticShX sh -> [i] -> ListX sh i
 listxFromList topssh topl = go topssh topl
   where
-    go :: StaticShX sh' -> [i] -> ListX sh' (Const i)
+    go :: StaticShX sh' -> [i] -> ListX sh' i
     go ZKX [] = ZX
-    go (_ :!% sh) (i : is) = Const i ::% go sh is
+    go (_ :!% sh) (i : is) = i ::% go sh is
     go _ _ = error $ "listxFromList: Mismatched list length (type says "
                        ++ show (ssxLength topssh) ++ ", list has length "
                        ++ show (length topl) ++ ")"
 
 {-# INLINEABLE listxToList #-}
-listxToList :: ListX sh (Const i) -> [i]
+listxToList :: ListX sh i -> [i]
 listxToList list = build (\(cons :: i -> is -> is) (nil :: is) ->
-  let go :: ListX sh (Const i) -> is
+  let go :: ListX sh i -> is
       go ZX = nil
-      go (Const i ::% is) = i `cons` go is
+      go (i ::% is) = i `cons` go is
   in go list)
 
-listxHead :: ListX (mn ': sh) f -> f mn
+listxHead :: ListX (mn ': sh) i -> i
 listxHead (i ::% _) = i
 
 listxTail :: ListX (n : sh) i -> ListX sh i
 listxTail (_ ::% sh) = sh
 
-listxAppend :: ListX sh f -> ListX sh' f -> ListX (sh ++ sh') f
+listxAppend :: ListX sh i -> ListX sh' i -> ListX (sh ++ sh') i
 listxAppend ZX idx' = idx'
 listxAppend (i ::% idx) idx' = i ::% listxAppend idx idx'
 
-listxDrop :: forall f g sh sh'. ListX sh g -> ListX (sh ++ sh') f -> ListX sh' f
+listxDrop :: forall i j sh sh'. ListX sh j -> ListX (sh ++ sh') i -> ListX sh' i
 listxDrop ZX long = long
 listxDrop (_ ::% short) long = case long of _ ::% long' -> listxDrop short long'
 
-listxInit :: forall f n sh. ListX (n : sh) f -> ListX (Init (n : sh)) f
+listxInit :: forall i n sh. ListX (n : sh) i -> ListX (Init (n : sh)) i
 listxInit (i ::% sh@(_ ::% _)) = i ::% listxInit sh
 listxInit (_ ::% ZX) = ZX
 
-listxLast :: forall f n sh. ListX (n : sh) f -> f (Last (n : sh))
+listxLast :: forall i n sh. ListX (n : sh) i -> i
 listxLast (_ ::% sh@(_ ::% _)) = listxLast sh
 listxLast (x ::% ZX) = x
 
-listxZip :: ListX sh f -> ListX sh g -> ListX sh (Product f g)
-listxZip ZX ZX = ZX
-listxZip (i ::% irest) (j ::% jrest) = Pair i j ::% listxZip irest jrest
-
 {-# INLINE listxZipWith #-}
-listxZipWith :: (forall a. f a -> g a -> h a) -> ListX sh f -> ListX sh g
-             -> ListX sh h
+listxZipWith :: (i -> j -> k) -> ListX sh i -> ListX sh j -> ListX sh k
 listxZipWith _ ZX ZX = ZX
 listxZipWith f (i ::% is) (j ::% js) = f i j ::% listxZipWith f is js
 
@@ -188,8 +164,8 @@ listxZipWith f (i ::% is) (j ::% js) = f i j ::% listxZipWith f is js
 -- | An index into a mixed-typed array.
 type role IxX nominal representational
 type IxX :: [Maybe Nat] -> Type -> Type
-newtype IxX sh i = IxX (ListX sh (Const i))
-  deriving (Eq, Ord, NFData)
+newtype IxX sh i = IxX (ListX sh i)
+  deriving (Eq, Ord, NFData, Functor, Foldable)
 
 pattern ZIX :: forall sh i. () => sh ~ '[] => IxX sh i
 pattern ZIX = IxX ZX
@@ -198,8 +174,8 @@ pattern (:.%)
   :: forall {sh1} {i}.
      forall n sh. (n : sh ~ sh1)
   => i -> IxX sh i -> IxX sh1 i
-pattern i :.% shl <- IxX (listxUncons -> Just (UnconsListXRes (IxX -> shl) (getConst -> i)))
-  where i :.% IxX shl = IxX (Const i ::% shl)
+pattern i :.% shl <- IxX (listxUncons -> Just (UnconsListXRes (IxX -> shl) i))
+  where i :.% IxX shl = IxX (i ::% shl)
 infixr 3 :.%
 
 {-# COMPLETE ZIX, (:.%) #-}
@@ -212,23 +188,9 @@ type IIxX sh = IxX sh Int
 deriving instance Show i => Show (IxX sh i)
 #else
 instance Show i => Show (IxX sh i) where
-  showsPrec _ (IxX l) = listxShow (shows . getConst) l
+  showsPrec _ (IxX l) = listxShow shows l
 #endif
 
-instance Functor (IxX sh) where
-  {-# INLINE fmap #-}
-  fmap f (IxX l) = IxX (listxFmap (Const . f . getConst) l)
-
-instance Foldable (IxX sh) where
-  {-# INLINE foldMap #-}
-  foldMap f (IxX l) = listxFoldMap (f . getConst) l
-  {-# INLINE foldr #-}
-  foldr _ z ZIX = z
-  foldr f z (x :.% xs) = f x (foldr f z xs)
-  toList = ixxToList
-  null ZIX = False
-  null _ = True
-
 ixxLength :: IxX sh i -> Int
 ixxLength (IxX l) = listxLength l
 
@@ -243,30 +205,30 @@ ixxZero' :: IShX sh -> IIxX sh
 ixxZero' ZSX = ZIX
 ixxZero' (_ :$% sh) = 0 :.% ixxZero' sh
 
+{-# INLINEABLE ixxFromList #-}
 ixxFromList :: forall sh i. StaticShX sh -> [i] -> IxX sh i
 ixxFromList = coerce (listxFromList @_ @i)
 
-{-# INLINEABLE ixxToList #-}
-ixxToList :: forall sh i. IxX sh i -> [i]
-ixxToList = coerce (listxToList @_ @i)
+ixxToList :: IxX sh i -> [i]
+ixxToList = Foldable.toList
 
 ixxHead :: IxX (n : sh) i -> i
-ixxHead (IxX list) = getConst (listxHead list)
+ixxHead (IxX list) = listxHead list
 
 ixxTail :: IxX (n : sh) i -> IxX sh i
 ixxTail (IxX list) = IxX (listxTail list)
 
 ixxAppend :: forall sh sh' i. IxX sh i -> IxX sh' i -> IxX (sh ++ sh') i
-ixxAppend = coerce (listxAppend @_ @(Const i))
+ixxAppend = coerce (listxAppend @_ @i)
 
 ixxDrop :: forall sh sh' i. IxX sh i -> IxX (sh ++ sh') i -> IxX sh' i
-ixxDrop = coerce (listxDrop @(Const i) @(Const i))
+ixxDrop = coerce (listxDrop @i @i)
 
 ixxInit :: forall n sh i. IxX (n : sh) i -> IxX (Init (n : sh)) i
-ixxInit = coerce (listxInit @(Const i))
+ixxInit = coerce (listxInit @i)
 
 ixxLast :: forall n sh i. IxX (n : sh) i -> i
-ixxLast = coerce (listxLast @(Const i))
+ixxLast = coerce (listxLast @i)
 
 ixxCast :: StaticShX sh' -> IxX sh i -> IxX sh' i
 ixxCast ZKX ZIX = ZIX
@@ -818,8 +780,8 @@ shxFlatten = go (SNat @1)
 
 
 -- | Very untyped: only length is checked (at runtime).
-instance KnownShX sh => IsList (ListX sh (Const i)) where
-  type Item (ListX sh (Const i)) = i
+instance KnownShX sh => IsList (ListX sh i) where
+  type Item (ListX sh i) = i
   fromList = listxFromList (knownShX @sh)
   toList = listxToList