From 9fa5556c4d4dc45ba2417081437bac2d1240132f Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Tue, 2 Dec 2025 15:15:35 +0100 Subject: Let sh*FromList functions print proper error messages --- src/Data/Array/Nested/Mixed/Shape.hs | 34 ++++++++++++++++++++-------------- src/Data/Array/Nested/Ranked/Shape.hs | 13 ++++++++----- src/Data/Array/Nested/Shaped/Shape.hs | 32 +++++++++++++++++++------------- 3 files changed, 47 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/Data/Array/Nested/Mixed/Shape.hs b/src/Data/Array/Nested/Mixed/Shape.hs index 5a45a09..900d045 100644 --- a/src/Data/Array/Nested/Mixed/Shape.hs +++ b/src/Data/Array/Nested/Mixed/Shape.hs @@ -133,11 +133,14 @@ listxShow f l = showString "[" . go "" l . showString "]" go prefix (x ::% xs) = showString prefix . f x . go "," xs listxFromList :: StaticShX sh -> [i] -> ListX sh (Const i) -listxFromList ZKX [] = ZX -listxFromList (_ :!% sh) (i : is) = Const i ::% listxFromList sh is -listxFromList sh l = error $ "listxFromList: Mismatched list length (type says " - ++ show (ssxLength sh) ++ ", list has length " - ++ show (length l) ++ ")" +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 $ "listxFromList: Mismatched list length (type says " + ++ show (ssxLength topssh) ++ ", list has length " + ++ show (length topl) ++ ")" {-# INLINEABLE listxToList #-} listxToList :: ListX sh' (Const i) -> [i] @@ -406,15 +409,18 @@ shxSize ZSX = 1 shxSize (n :$% sh) = fromSMayNat' n * shxSize sh shxFromList :: StaticShX sh -> [Int] -> IShX sh -shxFromList ZKX [] = ZSX -shxFromList (SKnown sn :!% sh) (i : is) - | i == fromSNat' sn = SKnown sn :$% shxFromList sh is - | otherwise = error $ "shxFromList: Value does not match typing (type says " - ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")" -shxFromList (SUnknown () :!% sh) (i : is) = SUnknown i :$% shxFromList sh is -shxFromList sh l = error $ "shxFromList: Mismatched list length (type says " - ++ show (ssxLength sh) ++ ", list has length " - ++ show (length l) ++ ")" +shxFromList topssh topl = go topssh topl + where + go :: StaticShX sh' -> [Int] -> IShX sh' + 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) ++ ")" {-# INLINEABLE shxToList #-} shxToList :: IShX sh -> [Int] diff --git a/src/Data/Array/Nested/Ranked/Shape.hs b/src/Data/Array/Nested/Ranked/Shape.hs index 02d65b6..2fea8c4 100644 --- a/src/Data/Array/Nested/Ranked/Shape.hs +++ b/src/Data/Array/Nested/Ranked/Shape.hs @@ -130,11 +130,14 @@ listrAppend ZR sh = sh listrAppend (x ::: xs) sh = x ::: listrAppend xs sh listrFromList :: SNat n -> [i] -> ListR n i -listrFromList SZ [] = ZR -listrFromList (SS n) (i : is) = i ::: listrFromList n is -listrFromList n l = error $ "listrFromList: Mismatched list length (type says " - ++ show (fromSNat n) ++ ", list has length " - ++ show (length l) ++ ")" +listrFromList topsn topl = go topsn topl + where + go :: SNat n' -> [i] -> ListR n' i + go SZ [] = ZR + go (SS n) (i : is) = i ::: go n is + go _ _ = error $ "listrFromList: Mismatched list length (type says " + ++ show (fromSNat topsn) ++ ", list has length " + ++ show (length topl) ++ ")" {-# INLINEABLE listrToList #-} listrToList :: ListR n i -> [i] 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] -- cgit v1.2.3-70-g09d2