From 607726b85cb83d2d29fafeca8cf73754b81995a4 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sat, 18 May 2024 22:13:01 +0200
Subject: WIP IsList instances

---
 src/Data/Array/Mixed.hs           | 42 +++++++++++++++++++++++++++++++++++++++
 src/Data/Array/Nested/Internal.hs |  8 --------
 2 files changed, 42 insertions(+), 8 deletions(-)

(limited to 'src/Data')

diff --git a/src/Data/Array/Mixed.hs b/src/Data/Array/Mixed.hs
index 03b411c..39d969c 100644
--- a/src/Data/Array/Mixed.hs
+++ b/src/Data/Array/Mixed.hs
@@ -34,6 +34,7 @@ import Data.Type.Bool
 import Data.Type.Equality
 import qualified Data.Vector.Storable as VS
 import Foreign.Storable (Storable)
+import GHC.IsList
 import GHC.TypeError
 import GHC.TypeLits
 import qualified GHC.TypeNats as TypeNats
@@ -223,6 +224,47 @@ instance Show (StaticShX sh) where
   showsPrec _ (StaticShX l) = showListX (fromSMayNat shows (shows . fromSNat)) l
 
 
+-- | Evidence for the static part of a shape. This pops up only when you are
+-- polymorphic in the element type of an array.
+type KnownShX :: [Maybe Nat] -> Constraint
+class KnownShX sh where knownShX :: StaticShX sh
+instance KnownShX '[] where knownShX = ZKX
+instance (KnownNat n, KnownShX sh) => KnownShX (Just n : sh) where knownShX = SKnown natSing :!% knownShX
+instance KnownShX sh => KnownShX (Nothing : sh) where knownShX = SUnknown () :!% knownShX
+
+
+-- | Very untyped; length is checked at runtime.
+instance KnownShX sh => IsList (ListX sh (Const i)) where
+  type Item (ListX sh (Const i)) = i
+  fromList = go (knownShX @sh)
+    where
+      go :: StaticShX sh' -> [i] -> ListX sh' (Const i)
+      go ZKX [] = ZX
+      go (_ :!% sh) (i : is) = Const i ::% go sh is
+      go _ _ = error "IsList(ListX): Mismatched list length"
+  toList = go
+    where
+      go :: ListX sh' (Const i) -> [i]
+      go ZX = []
+      go (Const i ::% is) = i : go is
+
+-- | Very untyped; length is checked at runtime, and index bounds are *not checked*.
+instance KnownShX sh => IsList (IxX sh i) where
+  type Item (IxX sh i) = i
+  fromList = IxX . fromList
+  toList (IxX l) = toList l
+
+-- | Very untyped; length is checked at runtime, and known dimensions are *not checked*.
+-- instance KnownShX sh => IsList (ShX sh i) where
+--   type Item (ShX sh i) = i
+--   fromList = ShX . fmapListX (\(Const i) -> _) . fromList
+--   toList = go
+--     where
+--       go :: ShX sh' i -> [i]
+--       go ZSX = []
+--       go (Const i :$% is) = i : go is
+
+
 type family Rank sh where
   Rank '[] = 0
   Rank (_ : sh) = 1 + Rank sh
diff --git a/src/Data/Array/Nested/Internal.hs b/src/Data/Array/Nested/Internal.hs
index c66bd07..b9adde9 100644
--- a/src/Data/Array/Nested/Internal.hs
+++ b/src/Data/Array/Nested/Internal.hs
@@ -731,14 +731,6 @@ instance Elt a => Elt (Mixed sh' a) where
 
   mvecsFreeze sh (MV_Nest sh' vecs) = M_Nest sh <$> mvecsFreeze (X.shAppend sh sh') vecs
 
--- | Evidence for the static part of a shape. This pops up only when you are
--- polymorphic in the element type of an array.
-type KnownShX :: [Maybe Nat] -> Constraint
-class KnownShX sh where knownShX :: StaticShX sh
-instance KnownShX '[] where knownShX = ZKX
-instance (KnownNat n, KnownShX sh) => KnownShX (Just n : sh) where knownShX = SKnown natSing :!% knownShX
-instance KnownShX sh => KnownShX (Nothing : sh) where knownShX = SUnknown () :!% knownShX
-
 instance (KnownShX sh', KnownElt a) => KnownElt (Mixed sh' a) where
   memptyArray sh = M_Nest sh (memptyArray (X.shAppend sh (X.completeShXzeros (knownShX @sh'))))
 
-- 
cgit v1.2.3-70-g09d2