Let sh*FromList functions print proper error messages

1 files changed, 19 insertions, 13 deletions

diff --git a/src/Data/Array/Nested/Shaped/Shape.hs b/src/Data/Array/Nested/Shaped/Shape.hs
index a237b88..378f622 100644
--- a/src/Data/Array/Nested/Shaped/Shape.hs
+++ b/src/Data/Array/Nested/Shaped/Shape.hs
@@ -129,11 +129,14 @@ listsRank ZS = SNat
 listsRank (_ ::$ sh) = snatSucc (listsRank sh)
 
 listsFromList :: ShS sh -> [i] -> ListS sh (Const i)
-listsFromList ZSS [] = ZS
-listsFromList (_ :$$ sh) (i : is) = Const i ::$ listsFromList sh is
-listsFromList sh l = error $ "listsFromList: Mismatched list length (type says "
-                             ++ show (shsLength sh) ++ ", list has length "
-                             ++ show (length l) ++ ")"
+listsFromList topsh topl = go topsh topl
+  where
+    go :: ShS sh' -> [i] -> ListS sh' (Const i)
+    go ZSS [] = ZS
+    go (_ :$$ sh) (i : is) = Const i ::$ go sh is
+    go _ _ = error $ "listsFromList: Mismatched list length (type says "
+                     ++ show (shsLength topsh) ++ ", list has length "
+                     ++ show (length topl) ++ ")"
 
 {-# INLINEABLE listsToList #-}
 listsToList :: ListS sh (Const i) -> [i]
@@ -355,14 +358,17 @@ shsSize (n :$$ sh) = fromSNat' n * shsSize sh
 -- | This is a partial @const@ that fails when the second argument
 -- doesn't match the first.
 shsFromList :: ShS sh -> [Int] -> ShS sh
-shsFromList sh0@ZSS [] = sh0
-shsFromList sh0@(sn :$$ sh) (i : is)
-  | i == fromSNat' sn = shsFromList sh is `seq` sh0
-  | otherwise = error $ "shsFromList: Value does not match typing (type says "
-                        ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")"
-shsFromList sh l = error $ "shsFromList: Mismatched list length (type says "
-                           ++ show (shsLength sh) ++ ", list has length "
-                           ++ show (length l) ++ ")"
+shsFromList topsh topl = go topsh topl
+  where
+    go :: ShS sh' -> [Int] -> ShS sh'
+    go sh0@ZSS [] = sh0
+    go sh0@(sn :$$ sh) (i : is)
+      | i == fromSNat' sn = go sh is `seq` sh0
+      | otherwise = error $ "shsFromList: Value does not match typing (type says "
+                            ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")"
+    go _ _ = error $ "shsFromList: Mismatched list length (type says "
+                     ++ show (shsLength topsh) ++ ", list has length "
+                     ++ show (length topl) ++ ")"
 
 {-# INLINEABLE shsToList #-}
 shsToList :: ShS sh -> [Int]