WIP IsList instances

1 files changed, 42 insertions, 0 deletions

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