1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE ConstraintKinds  #-}
3{-# LANGUAGE TupleSections    #-}
4{- |
5Provides functions that raise errors in corner cases instead of returning \"best effort\"
6results, then provides wrappers like the "Safe" module. For example:
7
8* @'takeExact' 3 [1,2]@ raises an error, in contrast to 'take' which would return
9  just two elements.
10
11* @'takeExact' (-1) [1,2]@ raises an error, in contrast to 'take' which would return
12  no elements.
13
14* @'zip' [1,2] [1]@ raises an error, in contrast to 'zip' which would only pair up the
15  first element.
16
17Note that the @May@ variants of these functions are /strict/ in at least the bit of the prefix
18of the list required to spot errors. The standard and @Note@ versions are lazy, but throw
19errors later in the process - they do not check upfront.
20-}
21module Safe.Exact(
22    -- * New functions
23    takeExact, dropExact, splitAtExact,
24    zipExact, zipWithExact,
25    zip3Exact, zipWith3Exact,
26    -- * Safe wrappers
27    takeExactMay, takeExactNote, takeExactDef,
28    dropExactMay, dropExactNote, dropExactDef,
29    splitAtExactMay, splitAtExactNote, splitAtExactDef,
30    zipExactMay, zipExactNote, zipExactDef,
31    zipWithExactMay, zipWithExactNote, zipWithExactDef,
32    zip3ExactMay, zip3ExactNote, zip3ExactDef,
33    zipWith3ExactMay, zipWith3ExactNote, zipWith3ExactDef,
34    ) where
35
36import Control.Arrow
37import Data.Maybe
38import Safe.Util
39import Safe.Partial
40
41---------------------------------------------------------------------
42-- HELPERS
43
44addNote :: Partial => String -> String -> String -> a
45addNote note fun msg = error $
46    "Safe.Exact." ++ fun ++ ", " ++ msg ++ (if null note then "" else ", " ++ note)
47
48
49---------------------------------------------------------------------
50-- IMPLEMENTATIONS
51
52{-# INLINE splitAtExact_ #-}
53splitAtExact_ :: Partial => (String -> r) -> ([a] -> r) -> (a -> r -> r) -> Int -> [a] -> r
54splitAtExact_ err nil cons o xs
55    | o < 0 = err $ "index must not be negative, index=" ++ show o
56    | otherwise = f o xs
57    where
58        f 0 xs = nil xs
59        f i (x:xs) = x `cons` f (i-1) xs
60        f i [] = err $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
61
62
63{-# INLINE zipWithExact_ #-}
64zipWithExact_ :: Partial => (String -> r) -> r -> (a -> b -> r -> r) -> [a] -> [b] -> r
65zipWithExact_ err nil cons = f
66    where
67        f (x:xs) (y:ys) = cons x y $ f xs ys
68        f [] [] = nil
69        f [] _ = err "second list is longer than the first"
70        f _ [] = err "first list is longer than the second"
71
72
73{-# INLINE zipWith3Exact_ #-}
74zipWith3Exact_ :: Partial => (String -> r) -> r -> (a -> b -> c -> r -> r) -> [a] -> [b] -> [c] -> r
75zipWith3Exact_ err nil cons = f
76    where
77        f (x:xs) (y:ys) (z:zs) = cons x y z $ f xs ys zs
78        f [] [] [] = nil
79        f [] _ _ = err "first list is shorter than the others"
80        f _ [] _ = err "second list is shorter than the others"
81        f _ _ [] = err "third list is shorter than the others"
82
83
84---------------------------------------------------------------------
85-- TAKE/DROP/SPLIT
86
87-- |
88-- > takeExact n xs =
89-- >   | n >= 0 && n <= length xs = take n xs
90-- >   | otherwise                = error "some message"
91takeExact :: Partial => Int -> [a] -> [a]
92takeExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "takeExact") (const []) (:) i xs
93
94-- |
95-- > dropExact n xs =
96-- >   | n >= 0 && n <= length xs = drop n xs
97-- >   | otherwise                = error "some message"
98dropExact :: Partial => Int -> [a] -> [a]
99dropExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "dropExact") id (flip const) i xs
100
101-- |
102-- > splitAtExact n xs =
103-- >   | n >= 0 && n <= length xs = splitAt n xs
104-- >   | otherwise                = error "some message"
105splitAtExact :: Partial => Int -> [a] -> ([a], [a])
106splitAtExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "splitAtExact")
107    ([],) (\a b -> first (a:) b) i xs
108
109takeExactNote :: Partial => String -> Int -> [a] -> [a]
110takeExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "takeExactNote") (const []) (:) i xs
111
112takeExactMay :: Int -> [a] -> Maybe [a]
113takeExactMay = splitAtExact_ (const Nothing) (const $ Just []) (\a -> fmap (a:))
114
115takeExactDef :: [a] -> Int -> [a] -> [a]
116takeExactDef def = fromMaybe def .^ takeExactMay
117
118dropExactNote :: Partial => String -> Int -> [a] -> [a]
119dropExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "dropExactNote") id (flip const) i xs
120
121dropExactMay :: Int -> [a] -> Maybe [a]
122dropExactMay = splitAtExact_ (const Nothing) Just (flip const)
123
124dropExactDef :: [a] -> Int -> [a] -> [a]
125dropExactDef def = fromMaybe def .^ dropExactMay
126
127splitAtExactNote :: Partial => String -> Int -> [a] -> ([a], [a])
128splitAtExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "splitAtExactNote")
129    ([],) (\a b -> first (a:) b) i xs
130
131splitAtExactMay :: Int -> [a] -> Maybe ([a], [a])
132splitAtExactMay = splitAtExact_ (const Nothing)
133    (\x -> Just ([], x)) (\a b -> fmap (first (a:)) b)
134
135splitAtExactDef :: ([a], [a]) -> Int -> [a] -> ([a], [a])
136splitAtExactDef def = fromMaybe def .^ splitAtExactMay
137
138---------------------------------------------------------------------
139-- ZIP
140
141-- |
142-- > zipExact xs ys =
143-- >   | length xs == length ys = zip xs ys
144-- >   | otherwise              = error "some message"
145zipExact :: Partial => [a] -> [b] -> [(a,b)]
146zipExact xs ys = withFrozenCallStack $ zipWithExact_ (addNote "" "zipExact") []  (\a b xs -> (a,b) : xs) xs ys
147
148-- |
149-- > zipWithExact f xs ys =
150-- >   | length xs == length ys = zipWith f xs ys
151-- >   | otherwise              = error "some message"
152zipWithExact :: Partial => (a -> b -> c) -> [a] -> [b] -> [c]
153zipWithExact f xs ys = withFrozenCallStack $ zipWithExact_ (addNote "" "zipWithExact") [] (\a b xs -> f a b : xs) xs ys
154
155
156zipExactNote :: Partial => String -> [a] -> [b] -> [(a,b)]
157zipExactNote note xs ys = withFrozenCallStack $ zipWithExact_ (addNote note "zipExactNote") []  (\a b xs -> (a,b) : xs) xs ys
158
159zipExactMay :: [a] -> [b] -> Maybe [(a,b)]
160zipExactMay = zipWithExact_ (const Nothing) (Just [])  (\a b xs -> fmap ((a,b) :) xs)
161
162zipExactDef :: [(a,b)] -> [a] -> [b] -> [(a,b)]
163zipExactDef def = fromMaybe def .^ zipExactMay
164
165zipWithExactNote :: Partial => String -> (a -> b -> c) -> [a] -> [b] -> [c]
166zipWithExactNote note f xs ys = withFrozenCallStack $ zipWithExact_ (addNote note "zipWithExactNote") []  (\a b xs -> f a b : xs) xs ys
167
168zipWithExactMay :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
169zipWithExactMay f = zipWithExact_ (const Nothing) (Just [])  (\a b xs -> fmap (f a b :) xs)
170
171zipWithExactDef :: [c] -> (a -> b -> c) -> [a] -> [b] -> [c]
172zipWithExactDef def = fromMaybe def .^^ zipWithExactMay
173
174
175-- |
176-- > zip3Exact xs ys zs =
177-- >   | length xs == length ys && length xs == length zs = zip3 xs ys zs
178-- >   | otherwise                                        = error "some message"
179zip3Exact :: Partial => [a] -> [b] -> [c] -> [(a,b,c)]
180zip3Exact xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote "" "zip3Exact") [] (\a b c xs -> (a, b, c) : xs) xs ys zs
181
182-- |
183-- > zipWith3Exact f xs ys zs =
184-- >   | length xs == length ys && length xs == length zs = zipWith3 f xs ys zs
185-- >   | otherwise                                        = error "some message"
186zipWith3Exact :: Partial => (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
187zipWith3Exact f xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote "" "zipWith3Exact") [] (\a b c xs -> f a b c : xs) xs ys zs
188
189
190zip3ExactNote :: Partial => String -> [a] -> [b] -> [c]-> [(a,b,c)]
191zip3ExactNote note xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote note "zip3ExactNote") [] (\a b c xs -> (a,b,c) : xs) xs ys zs
192
193zip3ExactMay :: [a] -> [b] -> [c] -> Maybe [(a,b,c)]
194zip3ExactMay = zipWith3Exact_ (const Nothing) (Just [])  (\a b c xs -> fmap ((a,b,c) :) xs)
195
196zip3ExactDef :: [(a,b,c)] -> [a] -> [b] -> [c] -> [(a,b,c)]
197zip3ExactDef def = fromMaybe def .^^ zip3ExactMay
198
199zipWith3ExactNote :: Partial => String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
200zipWith3ExactNote note f xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote note "zipWith3ExactNote") []  (\a b c xs -> f a b c : xs) xs ys zs
201
202zipWith3ExactMay :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> Maybe [d]
203zipWith3ExactMay f = zipWith3Exact_ (const Nothing) (Just [])  (\a b c xs -> fmap (f a b c :) xs)
204
205zipWith3ExactDef :: [d] -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
206zipWith3ExactDef def = fromMaybe def .^^^ zipWith3ExactMay
207