From 390af124e6cb50c4a2cd9006662fc26eef02889a Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 19 May 2024 12:55:58 +0200
Subject: Some IsList instances

---
 src/Data/Array/Nested/Internal.hs | 78 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)

(limited to 'src/Data/Array/Nested')

diff --git a/src/Data/Array/Nested/Internal.hs b/src/Data/Array/Nested/Internal.hs
index 8777960..a61e7d6 100644
--- a/src/Data/Array/Nested/Internal.hs
+++ b/src/Data/Array/Nested/Internal.hs
@@ -85,11 +85,14 @@ import Data.Foldable (toList)
 import Data.Functor.Const
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty(..))
+import Data.Monoid (Sum(..))
 import Data.Proxy
 import Data.Type.Equality
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Storable.Mutable as VSM
 import Foreign.Storable (Storable)
+import GHC.IsList (IsList)
+import qualified GHC.IsList as IsList
 import GHC.TypeLits
 import qualified GHC.TypeNats as TypeNats
 import Unsafe.Coerce
@@ -267,6 +270,34 @@ instance Show i => Show (ShR n i) where
   showsPrec _ (ShR l) = showListR shows l
 
 
+-- | Untyped: length is checked at runtime.
+instance KnownNat n => IsList (ListR n i) where
+  type Item (ListR n i) = i
+  fromList = go (SNat @n)
+    where
+      go :: SNat n' -> [i] -> ListR n' i
+      go SZ [] = ZR
+      go (SS n) (i : is) = i ::: go n is
+      go _ _ = error "IsList(ListR): Mismatched list length"
+  toList = go
+    where
+      go :: ListR n' i -> [i]
+      go ZR = []
+      go (i ::: is) = i : go is
+
+-- | Untyped: length is checked at runtime.
+instance KnownNat n => IsList (IxR n i) where
+  type Item (IxR n i) = i
+  fromList = IxR . IsList.fromList
+  toList (IxR idx) = IsList.toList idx
+
+-- | Untyped: length is checked at runtime.
+instance KnownNat n => IsList (ShR n i) where
+  type Item (ShR n i) = i
+  fromList = ShR . IsList.fromList
+  toList (ShR idx) = IsList.toList idx
+
+
 type role ListS nominal representational
 type ListS :: [Nat] -> (Nat -> Type) -> Type
 data ListS sh f where
@@ -360,6 +391,53 @@ infixr 3 :$$
 instance Show (ShS sh) where
   showsPrec _ (ShS l) = showListS (shows . fromSNat) l
 
+lengthShS :: ShS sh -> Int
+lengthShS (ShS l) = getSum (foldListS (\_ -> Sum 1) l)
+
+
+-- | Untyped: length is checked at runtime.
+instance KnownShS sh => IsList (ListS sh (Const i)) where
+  type Item (ListS sh (Const i)) = i
+  fromList topl = go (knownShS @sh) topl
+    where
+      go :: ShS sh' -> [i] -> ListS sh' (Const i)
+      go ZSS [] = ZS
+      go (_ :$$ sh) (i : is) = Const i ::$ go sh is
+      go _ _ = error $ "IsList(ListS): Mismatched list length (type says "
+                         ++ show (lengthShS (knownShS @sh)) ++ ", list has length "
+                         ++ show (length topl) ++ ")"
+  toList = go
+    where
+      go :: ListS sh' (Const i) -> [i]
+      go ZS = []
+      go (Const i ::$ is) = i : go is
+
+-- | Very untyped: only length is checked (at runtime), index bounds are __not checked__.
+instance KnownShS sh => IsList (IxS sh i) where
+  type Item (IxS sh i) = i
+  fromList = IxS . IsList.fromList
+  toList (IxS idx) = IsList.toList idx
+
+-- | Untyped: length and values are checked at runtime.
+instance KnownShS sh => IsList (ShS sh) where
+  type Item (ShS sh) = Int
+  fromList topl = ShS (go (knownShS @sh) topl)
+    where
+      go :: ShS sh' -> [Int] -> ListS sh' SNat
+      go ZSS [] = ZS
+      go (sn :$$ sh) (i : is)
+        | i == fromSNat' sn = sn ::$ go sh is
+        | otherwise = error $ "IsList(ShS): Value does not match typing (type says "
+                                ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")"
+      go _ _ = error $ "IsList(ShS): Mismatched list length (type says "
+                         ++ show (lengthShS (knownShS @sh)) ++ ", list has length "
+                         ++ show (length topl) ++ ")"
+  toList = go
+    where
+      go :: ShS sh' -> [Int]
+      go ZSS = []
+      go (sn :$$ sh) = fromSNat' sn : go sh
+
 
 -- | Wrapper type used as a tag to attach instances on. The instances on arrays
 -- of @'Primitive' a@ are more polymorphic than the direct instances for arrays
-- 
cgit v1.2.3-70-g09d2