From c8f99847359a92289cf0ded280069794f6abae6a Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 9 Jun 2024 22:55:27 +0200
Subject: Extract {listx,shx}FromList from IsList instances

Also add ixxFromList for consistency
---
 src/Data/Array/Mixed/Shape.hs | 49 +++++++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 20 deletions(-)

(limited to 'src')

diff --git a/src/Data/Array/Mixed/Shape.hs b/src/Data/Array/Mixed/Shape.hs
index 4343574..e46105d 100644
--- a/src/Data/Array/Mixed/Shape.hs
+++ b/src/Data/Array/Mixed/Shape.hs
@@ -92,6 +92,16 @@ listxShow f l = showString "[" . go "" l . showString "]"
     go _ ZX = id
     go prefix (x ::% xs) = showString prefix . f x . go "," xs
 
+listxFromList :: StaticShX sh -> [i] -> ListX sh (Const i)
+listxFromList topssh topl = go topssh topl
+  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 (type says "
+                       ++ show (ssxLength topssh) ++ ", list has length "
+                       ++ show (length topl) ++ ")"
+
 listxToList :: ListX sh' (Const i) -> [i]
 listxToList ZX = []
 listxToList (Const i ::% is) = i : listxToList is
@@ -150,6 +160,9 @@ ixxZero' :: IShX sh -> IIxX sh
 ixxZero' ZSX = ZIX
 ixxZero' (_ :$% sh) = 0 :.% ixxZero' sh
 
+ixxFromList :: forall sh i. StaticShX sh -> [i] -> IxX sh i
+ixxFromList = coerce (listxFromList @_ @i)
+
 ixxTail :: IxX (n : sh) i -> IxX sh i
 ixxTail (IxX list) = IxX (listxTail list)
 
@@ -274,6 +287,20 @@ shxSize :: IShX sh -> Int
 shxSize ZSX = 1
 shxSize (n :$% sh) = fromSMayNat' n * shxSize sh
 
+shxFromList :: StaticShX sh -> [Int] -> ShX sh Int
+shxFromList topssh topl = go topssh topl
+  where
+    go :: StaticShX sh' -> [Int] -> ShX sh' Int
+    go ZKX [] = ZSX
+    go (SKnown sn :!% sh) (i : is)
+      | i == fromSNat' sn = SKnown sn :$% go sh is
+      | otherwise = error $ "shxFromList: Value does not match typing (type says "
+                              ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")"
+    go (SUnknown () :!% sh) (i : is) = SUnknown i :$% go sh is
+    go _ _ = error $ "shxFromList: Mismatched list length (type says "
+                       ++ show (ssxLength topssh) ++ ", list has length "
+                       ++ show (length topl) ++ ")"
+
 shxToList :: IShX sh -> [Int]
 shxToList ZSX = []
 shxToList (smn :$% sh) = fromSMayNat' smn : shxToList sh
@@ -440,14 +467,7 @@ 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
-  fromList topl = go (knownShX @sh) topl
-    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 (type says "
-                         ++ show (ssxLength (knownShX @sh)) ++ ", list has length "
-                         ++ show (length topl) ++ ")"
+  fromList = listxFromList (knownShX @sh)
   toList = listxToList
 
 -- | Very untyped: only length is checked (at runtime), index bounds are __not checked__.
@@ -459,16 +479,5 @@ instance KnownShX sh => IsList (IxX sh i) where
 -- | Untyped: length and known dimensions are checked (at runtime).
 instance KnownShX sh => IsList (ShX sh Int) where
   type Item (ShX sh Int) = Int
-  fromList topl = ShX (go (knownShX @sh) topl)
-    where
-      go :: StaticShX sh' -> [Int] -> ListX sh' (SMayNat Int SNat)
-      go ZKX [] = ZX
-      go (SKnown sn :!% sh) (i : is)
-        | i == fromSNat' sn = SKnown sn ::% go sh is
-        | otherwise = error $ "IsList(ShX): Value does not match typing (type says "
-                                ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")"
-      go (SUnknown () :!% sh) (i : is) = SUnknown i ::% go sh is
-      go _ _ = error $ "IsList(ShX): Mismatched list length (type says "
-                         ++ show (ssxLength (knownShX @sh)) ++ ", list has length "
-                         ++ show (length topl) ++ ")"
+  fromList = shxFromList (knownShX @sh)
   toList = shxToList
-- 
cgit v1.2.3-70-g09d2