Implement ListX as [] with strict pattern synonyms

1 files changed, 5 insertions, 58 deletions

diff --git a/src/Data/Array/Nested/Mixed/Shape.hs b/src/Data/Array/Nested/Mixed/Shape.hs
index 2dfcc8c..611ec19 100644
--- a/src/Data/Array/Nested/Mixed/Shape.hs
+++ b/src/Data/Array/Nested/Mixed/Shape.hs
@@ -28,6 +28,7 @@
 module Data.Array.Nested.Mixed.Shape where
 
 import Control.DeepSeq (NFData(..))
+import Control.Exception (assert)
 import Data.Bifunctor (first)
 import Data.Coerce
 import Data.Foldable qualified as Foldable
@@ -43,6 +44,7 @@ import GHC.TypeLits
 import GHC.TypeLits.Orphans ()
 #endif
 
+import Data.Array.Nested.Mixed.ListX
 import Data.Array.Nested.Types
 
 
@@ -55,63 +57,14 @@ type family Rank sh where
 
 -- * Mixed lists
 
-type role ListX nominal representational
-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 Show i => Show (ListX sh i)
-#else
-instance Show i => Show (ListX sh i) where
-  showsPrec _ = listxShow shows
-#endif
-
-instance NFData i => NFData (ListX sh i) where
-  rnf ZX = ()
-  rnf (x ::% l) = rnf x `seq` rnf l
-
-instance Functor (ListX l) where
-  {-# INLINE fmap #-}
-  fmap _ ZX = ZX
-  fmap f (x ::% xs) = f x ::% fmap 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)
-  null ZX = False
-  null _ = True
+{-# INLINE listxFromList #-}
+listxFromList :: StaticShX sh -> [i] -> ListX sh i
+listxFromList sh l = assert (ssxLength sh == length l) $ IsList.fromList l
 
 listxRank :: ListX sh i -> SNat (Rank sh)
 listxRank ZX = SNat
 listxRank (_ ::% l) | SNat <- listxRank l = SNat
 
-{-# INLINE listxShow #-}
-listxShow :: forall sh i. (i -> ShowS) -> ListX sh i -> ShowS
-listxShow f l = showString "[" . go "" l . showString "]"
-  where
-    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 i
-listxFromList topssh topl = go topssh topl
-  where
-    go :: StaticShX sh' -> [i] -> ListX sh' i
-    go ZKX [] = ZX
-    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) ++ ")"
-
 listxHead :: ListX (mn ': sh) i -> i
 listxHead (i ::% _) = i
 
@@ -772,12 +725,6 @@ shxFlatten = go (SNat @1)
     goUnknown acc (SKnown sn :$% sh) = goUnknown (acc * fromSNat' sn) sh
 
 
--- | Very untyped: only length is checked (at runtime).
-instance KnownShX sh => IsList (ListX sh i) where
-  type Item (ListX sh i) = i
-  fromList = listxFromList (knownShX @sh)
-  toList = Foldable.toList
-
 -- | Very untyped: only length is checked (at runtime), index bounds are __not checked__.
 instance KnownShX sh => IsList (IxX sh i) where
   type Item (IxX sh i) = i