diff options
Diffstat (limited to 'src/Data/Array/Nested/Shaped')
| -rw-r--r-- | src/Data/Array/Nested/Shaped/Shape.hs | 32 |
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] |