diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,23 +1,58 @@
Changelog for Safe
-0.3.7
+0.3.21, released 2024-01-18
+ #34, mark headErr/tailErr as Partial
+0.3.20, released 2024-01-14
+ #34, add headErr, tailErr
+ #33, avoid using head/tail to avoid x-partial
+0.3.19, released 2020-05-24
+ #30, undeprecate maximumDef and friends, fold*1Def
+0.3.18, released 2019-12-04
+ #27, deprecate maximumDef and friends, fold*1Def
+ #27, add maximumBounded and friends
+ Stop supporting GHC 7.4 to 7.8
+0.3.17, released 2018-03-09
+ Improve the display of errors, less internal callstack
+ Add a few missing Partial constraints
+0.3.16, released 2018-01-06
+ #22, add Safe index
+0.3.15, released 2017-06-18
+ Support QuickCheck 2.10
+0.3.14, released 2017-02-15
+ #20, fix for GHC 7.10.1
+0.3.13, released 2017-02-09
+ #20, require GHC 7.4 or above
+0.3.12, released 2017-02-05
+ #19, add Safe.Partial exposing a Partial typeclass
+ #19, add support for GHC call stacks
+0.3.11, released 2017-01-22
+ #16, add Safe succ and pred
+ #16, add readEitherSafe for better errors than readEither
+ #14, add Safe zip3Exact
+0.3.10, released 2016-11-08
+ #15, add Safe cycle
+0.3.9, released 2015-05-09
+ #9, add Safe toEnum
+0.3.8, released 2014-08-10
+ #8, remove unnecessary Ord constraints from Foldable functions
+0.3.7, released 2014-07-16
Add Def variants of the Exact functions
-0.3.6
+0.3.6, released 2014-07-12
#6, remove unnecessary Ord constraints from maximumBy/minimumBy
-0.3.5
+0.3.5, released 2014-06-28
Add Safe elemIndexJust/findIndexJust functions
Add Safe scan functions
Add Safe minimumBy/maximumBy functions
Add a module of Exact functions
Add Foldable minimum functions
Clean up the Foldable module, deprecate the Safe variants
-0.3.4
+0.3.4, released 2014-01-30
#1, improve the string clipping in readNote
-0.3.3
+0.3.3, released 2011-11-15
#494, add foldl1' wrappings
-0.3.2
+0.3.2, released 2011-11-13
Add a Safe.Foldable module
-0.3.1
+0.3.1, released 2011-11-09
Add findJust, safe wrapping of fromJust/find
-0.3
+0.3, released 2010-11-10
Start of changelog
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2007-2014.
+Copyright Neil Mitchell 2007-2024.
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,15 @@
+# Safe [](https://hackage.haskell.org/package/safe) [](https://www.stackage.org/package/safe) [](https://github.com/ndmitchell/safe/actions)
+
+A library wrapping `Prelude`/`Data.List` functions that can throw exceptions, such as `head` and `!!`. Each unsafe function has up to four variants, e.g. with `tail`:
+
+* tail :: [a] -> [a], raises an error on `tail []`.
+* tailMay :: [a] -> Maybe [a], turns errors into `Nothing`.
+* tailDef :: [a] -> [a] -> [a], takes a default to return on errors.
+* tailNote :: String -> [a] -> [a], takes an extra argument which supplements the error message.
+* tailSafe :: [a] -> [a], returns some sensible default if possible, `[]` in the case of `tail`.
+
+This package is divided into three modules:
+
+* `Safe` contains safe variants of `Prelude` and `Data.List` functions.
+* `Safe.Foldable` contains safe variants of `Foldable` functions.
+* `Safe.Exact` creates crashing versions of functions like `zip` (errors if the lists are not equal) and `take` (errors if there are not enough elements), then wraps them to provide safe variants.
diff --git a/Safe.hs b/Safe.hs
--- a/Safe.hs
+++ b/Safe.hs
@@ -1,55 +1,82 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}
+
{- |
A module wrapping @Prelude@/@Data.List@ functions that can throw exceptions, such as @head@ and @!!@.
-Each unsafe function has up to four variants, e.g. with @tail@:
+Each unsafe function has up to five variants, e.g. with @tail@:
-* @'tail' :: [a] -> [a]@, raises an error on @tail []@.
+* @'tail' :: [a] -> [a]@, raises an error on @tail []@, as provided by 'Prelude'.
+* @'tailErr' :: [a] -> [a]@, alias for @tail@ that doesn't trigger an @x-partial@ warning and does raise errors.
+
* @'tailMay' :: [a] -> /Maybe/ [a]@, turns errors into @Nothing@.
* @'tailDef' :: /[a]/ -> [a] -> [a]@, takes a default to return on errors.
-* @'tailNote' :: /String/ -> [a] -> [a]@, takes an extra argument which supplements the error message.
+* @'tailNote' :: 'Partial' => /String/ -> [a] -> [a]@, takes an extra argument which supplements the error message.
* @'tailSafe' :: [a] -> [a]@, returns some sensible default if possible, @[]@ in the case of @tail@.
+All functions marked with the @'Partial'@ constraint are not total, and will produce stack traces on error, on GHC
+versions which support them (see "GHC.Stack").
+
This module also introduces some new functions, documented at the top of the module.
-}
module Safe(
-- * New functions
abort, at, lookupJust, findJust, elemIndexJust, findIndexJust,
+ -- * Partial functions
+ tailErr, headErr,
-- * Safe wrappers
tailMay, tailDef, tailNote, tailSafe,
initMay, initDef, initNote, initSafe,
headMay, headDef, headNote,
lastMay, lastDef, lastNote,
- minimumMay, minimumDef, minimumNote,
- maximumMay, maximumDef, maximumNote,
- minimumByMay, minimumByDef, minimumByNote,
- maximumByMay, maximumByDef, maximumByNote,
+ minimumMay, minimumNote,
+ maximumMay, maximumNote,
+ minimumByMay, minimumByNote,
+ maximumByMay, maximumByNote,
+ minimumBoundBy, maximumBoundBy,
+ maximumBounded, maximumBound,
+ minimumBounded, minimumBound,
foldr1May, foldr1Def, foldr1Note,
foldl1May, foldl1Def, foldl1Note,
foldl1May', foldl1Def', foldl1Note',
scanl1May, scanl1Def, scanl1Note,
scanr1May, scanr1Def, scanr1Note,
+ cycleMay, cycleDef, cycleNote,
fromJustDef, fromJustNote,
assertNote,
atMay, atDef, atNote,
- readMay, readDef, readNote,
+ readMay, readDef, readNote, readEitherSafe,
lookupJustDef, lookupJustNote,
findJustDef, findJustNote,
elemIndexJustDef, elemIndexJustNote,
findIndexJustDef, findIndexJustNote,
+ toEnumMay, toEnumDef, toEnumNote, toEnumSafe,
+ succMay, succDef, succNote, succSafe,
+ predMay, predDef, predNote, predSafe,
+ indexMay, indexDef, indexNote,
+ -- * Discouraged
+ minimumDef, maximumDef, minimumByDef, maximumByDef
) where
import Safe.Util
+import Data.Ix
import Data.List
import Data.Maybe
+import Safe.Partial
---------------------------------------------------------------------
-- UTILITIES
+fromNote :: Partial => String -> String -> Maybe a -> a
fromNote = fromNoteModule "Safe"
+
+fromNoteEither :: Partial => String -> String -> Either String a -> a
fromNoteEither = fromNoteEitherModule "Safe"
@@ -59,8 +86,8 @@
-- | Synonym for 'error'. Used for instances where the program
-- has decided to exit because of invalid user input, or the user pressed
-- quit etc. This function allows 'error' to be reserved for programmer errors.
-abort :: String -> a
-abort = error
+abort :: Partial => String -> a
+abort x = withFrozenCallStack (error x)
at_ :: [a] -> Int -> Either String a
@@ -71,25 +98,31 @@
f i [] = Left $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
-read_ :: Read a => String -> Either String a
-read_ s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> Right x
- [] -> Left $ "no parse on " ++ prefix
- _ -> Left $ "ambiguous parse on " ++ prefix
- where
- maxLength = 15
- prefix = '\"' : a ++ if length s <= maxLength then (b ++ "\"") else "...\""
- where (a,b) = splitAt (maxLength - 3) s
-
-
---------------------------------------------------------------------
-- WRAPPERS
+-- | Identical to 'tail', namely that fails on an empty list.
+-- Useful to avoid the @x-partial@ warning introduced in GHC 9.8.
+--
+-- > tailErr [] = error "Prelude.tail: empty list"
+-- > tailErr [1,2,3] = [2,3]
+tailErr :: Partial => [a] -> [a]
+tailErr = tail
+
+-- | Identical to 'head', namely that fails on an empty list.
+-- Useful to avoid the @x-partial@ warning introduced in GHC 9.8.
+--
+-- > headErr [] = error "Prelude.head: empty list"
+-- > headErr [1,2,3] = 1
+headErr :: Partial => [a] -> a
+headErr = head
+
-- |
-- > tailMay [] = Nothing
-- > tailMay [1,3,4] = Just [3,4]
tailMay :: [a] -> Maybe [a]
-tailMay = liftMay null tail
+tailMay [] = Nothing
+tailMay (_:xs) = Just xs
-- |
-- > tailDef [12] [] = [12]
@@ -100,8 +133,8 @@
-- |
-- > tailNote "help me" [] = error "Safe.tailNote [], help me"
-- > tailNote "help me" [1,3,4] = [3,4]
-tailNote :: String -> [a] -> [a]
-tailNote note = fromNote note "tailNote []" . tailMay
+tailNote :: Partial => String -> [a] -> [a]
+tailNote note x = withFrozenCallStack $ fromNote note "tailNote []" $ tailMay x
-- |
-- > tailSafe [] = []
@@ -116,8 +149,8 @@
initDef :: [a] -> [a] -> [a]
initDef def = fromMaybe def . initMay
-initNote :: String -> [a] -> [a]
-initNote note = fromNote note "initNote []" . initMay
+initNote :: Partial => String -> [a] -> [a]
+initNote note x = withFrozenCallStack $ fromNote note "initNote []" $ initMay x
initSafe :: [a] -> [a]
initSafe = initDef []
@@ -125,56 +158,72 @@
headMay, lastMay :: [a] -> Maybe a
-headMay = liftMay null head
+headMay = listToMaybe
lastMay = liftMay null last
headDef, lastDef :: a -> [a] -> a
headDef def = fromMaybe def . headMay
lastDef def = fromMaybe def . lastMay
-headNote, lastNote :: String -> [a] -> a
-headNote note = fromNote note "headNote []" . headMay
-lastNote note = fromNote note "lastNote []" . lastMay
+headNote, lastNote :: Partial => String -> [a] -> a
+headNote note x = withFrozenCallStack $ fromNote note "headNote []" $ headMay x
+lastNote note x = withFrozenCallStack $ fromNote note "lastNote []" $ lastMay x
minimumMay, maximumMay :: Ord a => [a] -> Maybe a
minimumMay = liftMay null minimum
maximumMay = liftMay null maximum
-minimumDef, maximumDef :: Ord a => a -> [a] -> a
-minimumDef def = fromMaybe def . minimumMay
-maximumDef def = fromMaybe def . maximumMay
-
-minimumNote, maximumNote :: Ord a => String -> [a] -> a
-minimumNote note = fromNote note "minumumNote []" . minimumMay
-maximumNote note = fromNote note "maximumNote []" . maximumMay
+minimumNote, maximumNote :: (Partial, Ord a) => String -> [a] -> a
+minimumNote note x = withFrozenCallStack $ fromNote note "minumumNote []" $ minimumMay x
+maximumNote note x = withFrozenCallStack $ fromNote note "maximumNote []" $ maximumMay x
minimumByMay, maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
minimumByMay = liftMay null . minimumBy
maximumByMay = liftMay null . maximumBy
-minimumByDef, maximumByDef :: a -> (a -> a -> Ordering) -> [a] -> a
-minimumByDef def = fromMaybe def .^ minimumByMay
-maximumByDef def = fromMaybe def .^ maximumByMay
+minimumByNote, maximumByNote :: Partial => String -> (a -> a -> Ordering) -> [a] -> a
+minimumByNote note f x = withFrozenCallStack $ fromNote note "minumumByNote []" $ minimumByMay f x
+maximumByNote note f x = withFrozenCallStack $ fromNote note "maximumByNote []" $ maximumByMay f x
-minimumByNote, maximumByNote :: String -> (a -> a -> Ordering) -> [a] -> a
-minimumByNote note = fromNote note "minumumByNote []" .^ minimumByMay
-maximumByNote note = fromNote note "maximumByNote []" .^ maximumByMay
+-- | The largest element of a list with respect to the
+-- given comparison function. The result is bounded by the value given as the first argument.
+maximumBoundBy :: a -> (a -> a -> Ordering) -> [a] -> a
+maximumBoundBy x f xs = maximumBy f $ x : xs
+-- | The smallest element of a list with respect to the
+-- given comparison function. The result is bounded by the value given as the first argument.
+minimumBoundBy :: a -> (a -> a -> Ordering) -> [a] -> a
+minimumBoundBy x f xs = minimumBy f $ x : xs
+-- | The largest element of a list.
+-- The result is bounded by the value given as the first argument.
+maximumBound :: Ord a => a -> [a] -> a
+maximumBound x xs = maximum $ x : xs
+
+-- | The smallest element of a list.
+-- The result is bounded by the value given as the first argument.
+minimumBound :: Ord a => a -> [a] -> a
+minimumBound x xs = minimum $ x : xs
+
+-- | The largest element of a list.
+-- The result is bounded by 'minBound'.
+maximumBounded :: (Ord a, Bounded a) => [a] -> a
+maximumBounded = maximumBound minBound
+
+-- | The largest element of a list.
+-- The result is bounded by 'maxBound'.
+minimumBounded :: (Ord a, Bounded a) => [a] -> a
+minimumBounded = minimumBound maxBound
+
foldr1May, foldl1May, foldl1May' :: (a -> a -> a) -> [a] -> Maybe a
foldr1May = liftMay null . foldr1
foldl1May = liftMay null . foldl1
foldl1May' = liftMay null . foldl1'
-foldr1Def, foldl1Def, foldl1Def' :: a -> (a -> a -> a) -> [a] -> a
-foldr1Def def = fromMaybe def .^ foldr1May
-foldl1Def def = fromMaybe def .^ foldl1May
-foldl1Def' def = fromMaybe def .^ foldl1May'
-
-foldr1Note, foldl1Note, foldl1Note' :: String -> (a -> a -> a) -> [a] -> a
-foldr1Note note = fromNote note "foldr1Note []" .^ foldr1May
-foldl1Note note = fromNote note "foldl1Note []" .^ foldl1May
-foldl1Note' note = fromNote note "foldl1Note []" .^ foldl1May'
+foldr1Note, foldl1Note, foldl1Note' :: Partial => String -> (a -> a -> a) -> [a] -> a
+foldr1Note note f x = withFrozenCallStack $ fromNote note "foldr1Note []" $ foldr1May f x
+foldl1Note note f x = withFrozenCallStack $ fromNote note "foldl1Note []" $ foldl1May f x
+foldl1Note' note f x = withFrozenCallStack $ fromNote note "foldl1Note []" $ foldl1May' f x
scanr1May, scanl1May :: (a -> a -> a) -> [a] -> Maybe [a]
scanr1May = liftMay null . scanr1
@@ -184,25 +233,34 @@
scanr1Def def = fromMaybe def .^ scanr1May
scanl1Def def = fromMaybe def .^ scanl1May
-scanr1Note, scanl1Note :: String -> (a -> a -> a) -> [a] -> [a]
-scanr1Note note = fromNote note "scanr1Note []" .^ scanr1May
-scanl1Note note = fromNote note "scanl1Note []" .^ scanl1May
+scanr1Note, scanl1Note :: Partial => String -> (a -> a -> a) -> [a] -> [a]
+scanr1Note note f x = withFrozenCallStack $ fromNote note "scanr1Note []" $ scanr1May f x
+scanl1Note note f x = withFrozenCallStack $ fromNote note "scanl1Note []" $ scanl1May f x
+cycleMay :: [a] -> Maybe [a]
+cycleMay = liftMay null cycle
+
+cycleDef :: [a] -> [a] -> [a]
+cycleDef def = fromMaybe def . cycleMay
+
+cycleNote :: Partial => String -> [a] -> [a]
+cycleNote note x = withFrozenCallStack $ fromNote note "cycleNote []" $ cycleMay x
+
-- | An alternative name for 'fromMaybe', to fit the naming scheme of this package.
-- Generally using 'fromMaybe' directly would be considered better style.
fromJustDef :: a -> Maybe a -> a
fromJustDef = fromMaybe
-fromJustNote :: String -> Maybe a -> a
-fromJustNote note = fromNote note "fromJustNote Nothing"
+fromJustNote :: Partial => String -> Maybe a -> a
+fromJustNote note x = withFrozenCallStack $ fromNote note "fromJustNote Nothing" x
-assertNote :: String -> Bool -> a -> a
+assertNote :: Partial => String -> Bool -> a -> a
assertNote note True val = val
-assertNote note False val = fromNote note "assertNote False" Nothing
+assertNote note False val = withFrozenCallStack $ fromNote note "assertNote False" Nothing
-- | Synonym for '!!', but includes more information in the error message.
-at :: [a] -> Int -> a
+at :: Partial => [a] -> Int -> a
at = fromNoteEither "" "at" .^ at_
atMay :: [a] -> Int -> Maybe a
@@ -211,29 +269,40 @@
atDef :: a -> [a] -> Int -> a
atDef def = fromMaybe def .^ atMay
-atNote :: String -> [a] -> Int -> a
-atNote note = fromNoteEither note "atNote" .^ at_
+atNote :: Partial => String -> [a] -> Int -> a
+atNote note f x = withFrozenCallStack $ fromNoteEither note "atNote" $ at_ f x
+-- | This function provides a more precise error message than 'readEither' from 'base'.
+readEitherSafe :: Read a => String -> Either String a
+readEitherSafe s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Right x
+ [] -> Left $ "no parse on " ++ prefix
+ _ -> Left $ "ambiguous parse on " ++ prefix
+ where
+ maxLength = 15
+ prefix = '\"' : a ++ if length s <= maxLength then b ++ "\"" else "...\""
+ where (a,b) = splitAt (maxLength - 3) s
readMay :: Read a => String -> Maybe a
-readMay = eitherToMaybe . read_
+readMay = eitherToMaybe . readEitherSafe
readDef :: Read a => a -> String -> a
readDef def = fromMaybe def . readMay
-readNote :: Read a => String -> String -> a
-readNote note = fromNoteEither note "readNote" . read_
+-- | 'readNote' uses 'readEitherSafe' for the error message.
+readNote :: (Partial, Read a) => String -> String -> a
+readNote note x = withFrozenCallStack $ fromNoteEither note "readNote" $ readEitherSafe x
-- |
-- > lookupJust key = fromJust . lookup key
-lookupJust :: Eq a => a -> [(a,b)] -> b
-lookupJust = fromNote "" "lookupJust, no matching value" .^ lookup
+lookupJust :: (Eq a, Partial) => a -> [(a,b)] -> b
+lookupJust x xs = withFrozenCallStack $ fromNote "" "lookupJust, no matching value" $ lookup x xs
lookupJustDef :: Eq a => b -> a -> [(a,b)] -> b
lookupJustDef def = fromMaybe def .^ lookup
-lookupJustNote :: Eq a => String -> a -> [(a,b)] -> b
-lookupJustNote note = fromNote note "lookupJustNote, no matching value" .^ lookup
+lookupJustNote :: (Partial, Eq a) => String -> a -> [(a,b)] -> b
+lookupJustNote note x xs = withFrozenCallStack $ fromNote note "lookupJustNote, no matching value" $ lookup x xs
-- |
-- > findJust op = fromJust . find op
@@ -243,27 +312,106 @@
findJustDef :: a -> (a -> Bool) -> [a] -> a
findJustDef def = fromMaybe def .^ find
-findJustNote :: String -> (a -> Bool) -> [a] -> a
-findJustNote note = fromNote note "findJustNote, no matching value" .^ find
+findJustNote :: Partial => String -> (a -> Bool) -> [a] -> a
+findJustNote note f x = withFrozenCallStack $ fromNote note "findJustNote, no matching value" $ find f x
-- |
-- > elemIndexJust op = fromJust . elemIndex op
-elemIndexJust :: Eq a => a -> [a] -> Int
-elemIndexJust = fromNote "" "elemIndexJust, no matching value" .^ elemIndex
+elemIndexJust :: (Partial, Eq a) => a -> [a] -> Int
+elemIndexJust x xs = withFrozenCallStack $ fromNote "" "elemIndexJust, no matching value" $ elemIndex x xs
elemIndexJustDef :: Eq a => Int -> a -> [a] -> Int
elemIndexJustDef def = fromMaybe def .^ elemIndex
-elemIndexJustNote :: Eq a => String -> a -> [a] -> Int
-elemIndexJustNote note = fromNote note "elemIndexJustNote, no matching value" .^ elemIndex
+elemIndexJustNote :: (Partial, Eq a) => String -> a -> [a] -> Int
+elemIndexJustNote note x xs = withFrozenCallStack $ fromNote note "elemIndexJustNote, no matching value" $ elemIndex x xs
-- |
-- > findIndexJust op = fromJust . findIndex op
findIndexJust :: (a -> Bool) -> [a] -> Int
-findIndexJust = fromNote "" "findIndexJust, no matching value" .^ findIndex
+findIndexJust f x = withFrozenCallStack $ fromNote "" "findIndexJust, no matching value" $ findIndex f x
findIndexJustDef :: Int -> (a -> Bool) -> [a] -> Int
findIndexJustDef def = fromMaybe def .^ findIndex
-findIndexJustNote :: String -> (a -> Bool) -> [a] -> Int
-findIndexJustNote note = fromNote note "findIndexJustNote, no matching value" .^ findIndex
+findIndexJustNote :: Partial => String -> (a -> Bool) -> [a] -> Int
+findIndexJustNote note f x = withFrozenCallStack $ fromNote note "findIndexJustNote, no matching value" $ findIndex f x
+
+-- From http://stackoverflow.com/questions/2743858/safe-and-polymorphic-toenum
+-- answer by C. A. McCann
+toEnumMay :: (Enum a, Bounded a) => Int -> Maybe a
+toEnumMay i =
+ let r = toEnum i
+ max = maxBound `asTypeOf` r
+ min = minBound `asTypeOf` r
+ in if i >= fromEnum min && i <= fromEnum max
+ then Just r
+ else Nothing
+
+toEnumDef :: (Enum a, Bounded a) => a -> Int -> a
+toEnumDef def = fromMaybe def . toEnumMay
+
+toEnumNote :: (Partial, Enum a, Bounded a) => String -> Int -> a
+toEnumNote note x = withFrozenCallStack $ fromNote note "toEnumNote, out of range" $ toEnumMay x
+
+toEnumSafe :: (Enum a, Bounded a) => Int -> a
+toEnumSafe = toEnumDef minBound
+
+succMay :: (Enum a, Eq a, Bounded a) => a -> Maybe a
+succMay = liftMay (== maxBound) succ
+
+succDef :: (Enum a, Eq a, Bounded a) => a -> a -> a
+succDef def = fromMaybe def . succMay
+
+succNote :: (Partial, Enum a, Eq a, Bounded a) => String -> a -> a
+succNote note x = withFrozenCallStack $ fromNote note "succNote, out of range" $ succMay x
+
+succSafe :: (Enum a, Eq a, Bounded a) => a -> a
+succSafe = succDef maxBound
+
+predMay :: (Enum a, Eq a, Bounded a) => a -> Maybe a
+predMay = liftMay (== minBound) pred
+
+predDef :: (Enum a, Eq a, Bounded a) => a -> a -> a
+predDef def = fromMaybe def . predMay
+
+predNote :: (Partial, Enum a, Eq a, Bounded a) => String -> a -> a
+predNote note x = withFrozenCallStack $ fromNote note "predNote, out of range" $ predMay x
+
+predSafe :: (Enum a, Eq a, Bounded a) => a -> a
+predSafe = predDef minBound
+
+indexMay :: Ix a => (a, a) -> a -> Maybe Int
+indexMay b i = if inRange b i then Just (index b i) else Nothing
+
+indexDef :: Ix a => Int -> (a, a) -> a -> Int
+indexDef def b = fromMaybe def . indexMay b
+
+indexNote :: (Partial, Ix a) => String -> (a, a) -> a -> Int
+indexNote note x y = withFrozenCallStack $ fromNote note "indexNote, out of range" $ indexMay x y
+
+
+---------------------------------------------------------------------
+-- DISCOURAGED
+
+-- | New users are recommended to use 'minimumBound' or 'maximumBound' instead.
+minimumDef, maximumDef :: Ord a => a -> [a] -> a
+minimumDef def = fromMaybe def . minimumMay
+maximumDef def = fromMaybe def . maximumMay
+
+-- | New users are recommended to use 'minimumBoundBy' or 'maximumBoundBy' instead.
+minimumByDef, maximumByDef :: a -> (a -> a -> Ordering) -> [a] -> a
+minimumByDef def = fromMaybe def .^ minimumByMay
+maximumByDef def = fromMaybe def .^ maximumByMay
+
+
+---------------------------------------------------------------------
+-- DEPRECATED
+
+{-# DEPRECATED foldr1Def "Use @foldr1May@ instead." #-}
+{-# DEPRECATED foldl1Def "Use @foldl1May@ instead." #-}
+{-# DEPRECATED foldl1Def' "Use @foldl1May'@ instead." #-}
+foldr1Def, foldl1Def, foldl1Def' :: a -> (a -> a -> a) -> [a] -> a
+foldr1Def def = fromMaybe def .^ foldr1May
+foldl1Def def = fromMaybe def .^ foldl1May
+foldl1Def' def = fromMaybe def .^ foldl1May'
diff --git a/Safe/Exact.hs b/Safe/Exact.hs
--- a/Safe/Exact.hs
+++ b/Safe/Exact.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
{- |
Provides functions that raise errors in corner cases instead of returning \"best effort\"
results, then provides wrappers like the "Safe" module. For example:
@@ -19,21 +22,26 @@
-- * New functions
takeExact, dropExact, splitAtExact,
zipExact, zipWithExact,
+ zip3Exact, zipWith3Exact,
-- * Safe wrappers
takeExactMay, takeExactNote, takeExactDef,
dropExactMay, dropExactNote, dropExactDef,
splitAtExactMay, splitAtExactNote, splitAtExactDef,
zipExactMay, zipExactNote, zipExactDef,
zipWithExactMay, zipWithExactNote, zipWithExactDef,
+ zip3ExactMay, zip3ExactNote, zip3ExactDef,
+ zipWith3ExactMay, zipWith3ExactNote, zipWith3ExactDef,
) where
import Control.Arrow
import Data.Maybe
import Safe.Util
+import Safe.Partial
---------------------------------------------------------------------
-- HELPERS
+addNote :: Partial => String -> String -> String -> a
addNote note fun msg = error $
"Safe.Exact." ++ fun ++ ", " ++ msg ++ (if null note then "" else ", " ++ note)
@@ -42,7 +50,7 @@
-- IMPLEMENTATIONS
{-# INLINE splitAtExact_ #-}
-splitAtExact_ :: (String -> r) -> ([a] -> r) -> (a -> r -> r) -> Int -> [a] -> r
+splitAtExact_ :: Partial => (String -> r) -> ([a] -> r) -> (a -> r -> r) -> Int -> [a] -> r
splitAtExact_ err nil cons o xs
| o < 0 = err $ "index must not be negative, index=" ++ show o
| otherwise = f o xs
@@ -53,7 +61,7 @@
{-# INLINE zipWithExact_ #-}
-zipWithExact_ :: (String -> r) -> r -> (a -> b -> r -> r) -> [a] -> [b] -> r
+zipWithExact_ :: Partial => (String -> r) -> r -> (a -> b -> r -> r) -> [a] -> [b] -> r
zipWithExact_ err nil cons = f
where
f (x:xs) (y:ys) = cons x y $ f xs ys
@@ -62,6 +70,17 @@
f _ [] = err "first list is longer than the second"
+{-# INLINE zipWith3Exact_ #-}
+zipWith3Exact_ :: Partial => (String -> r) -> r -> (a -> b -> c -> r -> r) -> [a] -> [b] -> [c] -> r
+zipWith3Exact_ err nil cons = f
+ where
+ f (x:xs) (y:ys) (z:zs) = cons x y z $ f xs ys zs
+ f [] [] [] = nil
+ f [] _ _ = err "first list is shorter than the others"
+ f _ [] _ = err "second list is shorter than the others"
+ f _ _ [] = err "third list is shorter than the others"
+
+
---------------------------------------------------------------------
-- TAKE/DROP/SPLIT
@@ -69,26 +88,26 @@
-- > takeExact n xs =
-- > | n >= 0 && n <= length xs = take n xs
-- > | otherwise = error "some message"
-takeExact :: Int -> [a] -> [a]
-takeExact = splitAtExact_ (addNote "" "takeExact") (const []) (:)
+takeExact :: Partial => Int -> [a] -> [a]
+takeExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "takeExact") (const []) (:) i xs
-- |
-- > dropExact n xs =
-- > | n >= 0 && n <= length xs = drop n xs
-- > | otherwise = error "some message"
-dropExact :: Int -> [a] -> [a]
-dropExact = splitAtExact_ (addNote "" "dropExact") id (flip const)
+dropExact :: Partial => Int -> [a] -> [a]
+dropExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "dropExact") id (\_ x -> x) i xs
-- |
-- > splitAtExact n xs =
-- > | n >= 0 && n <= length xs = splitAt n xs
-- > | otherwise = error "some message"
-splitAtExact :: Int -> [a] -> ([a], [a])
-splitAtExact = splitAtExact_ (addNote "" "splitAtExact")
- (\x -> ([], x)) (\a b -> first (a:) b)
+splitAtExact :: Partial => Int -> [a] -> ([a], [a])
+splitAtExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "splitAtExact")
+ ([],) (\a b -> first (a:) b) i xs
-takeExactNote :: String -> Int -> [a] -> [a]
-takeExactNote note = splitAtExact_ (addNote note "takeExactNote") (const []) (:)
+takeExactNote :: Partial => String -> Int -> [a] -> [a]
+takeExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "takeExactNote") (const []) (:) i xs
takeExactMay :: Int -> [a] -> Maybe [a]
takeExactMay = splitAtExact_ (const Nothing) (const $ Just []) (\a -> fmap (a:))
@@ -96,18 +115,18 @@
takeExactDef :: [a] -> Int -> [a] -> [a]
takeExactDef def = fromMaybe def .^ takeExactMay
-dropExactNote :: String -> Int -> [a] -> [a]
-dropExactNote note = splitAtExact_ (addNote note "dropExactNote") id (flip const)
+dropExactNote :: Partial => String -> Int -> [a] -> [a]
+dropExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "dropExactNote") id (\_ x -> x) i xs
dropExactMay :: Int -> [a] -> Maybe [a]
-dropExactMay = splitAtExact_ (const Nothing) Just (flip const)
+dropExactMay = splitAtExact_ (const Nothing) Just (\_ x -> x)
dropExactDef :: [a] -> Int -> [a] -> [a]
dropExactDef def = fromMaybe def .^ dropExactMay
-splitAtExactNote :: String -> Int -> [a] -> ([a], [a])
-splitAtExactNote note = splitAtExact_ (addNote note "splitAtExactNote")
- (\x -> ([], x)) (\a b -> first (a:) b)
+splitAtExactNote :: Partial => String -> Int -> [a] -> ([a], [a])
+splitAtExactNote note i xs = withFrozenCallStack $ splitAtExact_ (addNote note "splitAtExactNote")
+ ([],) (\a b -> first (a:) b) i xs
splitAtExactMay :: Int -> [a] -> Maybe ([a], [a])
splitAtExactMay = splitAtExact_ (const Nothing)
@@ -123,19 +142,19 @@
-- > zipExact xs ys =
-- > | length xs == length ys = zip xs ys
-- > | otherwise = error "some message"
-zipExact :: [a] -> [b] -> [(a,b)]
-zipExact = zipWithExact_ (addNote "" "zipExact") [] (\a b xs -> (a,b) : xs)
+zipExact :: Partial => [a] -> [b] -> [(a,b)]
+zipExact xs ys = withFrozenCallStack $ zipWithExact_ (addNote "" "zipExact") [] (\a b xs -> (a,b) : xs) xs ys
-- |
-- > zipWithExact f xs ys =
-- > | length xs == length ys = zipWith f xs ys
-- > | otherwise = error "some message"
-zipWithExact :: (a -> b -> c) -> [a] -> [b] -> [c]
-zipWithExact f = zipWithExact_ (addNote "" "zipWithExact") [] (\a b xs -> f a b : xs)
+zipWithExact :: Partial => (a -> b -> c) -> [a] -> [b] -> [c]
+zipWithExact f xs ys = withFrozenCallStack $ zipWithExact_ (addNote "" "zipWithExact") [] (\a b xs -> f a b : xs) xs ys
-zipExactNote :: String -> [a] -> [b] -> [(a,b)]
-zipExactNote note = zipWithExact_ (addNote note "zipExactNote") [] (\a b xs -> (a,b) : xs)
+zipExactNote :: Partial => String -> [a] -> [b] -> [(a,b)]
+zipExactNote note xs ys = withFrozenCallStack $ zipWithExact_ (addNote note "zipExactNote") [] (\a b xs -> (a,b) : xs) xs ys
zipExactMay :: [a] -> [b] -> Maybe [(a,b)]
zipExactMay = zipWithExact_ (const Nothing) (Just []) (\a b xs -> fmap ((a,b) :) xs)
@@ -143,11 +162,45 @@
zipExactDef :: [(a,b)] -> [a] -> [b] -> [(a,b)]
zipExactDef def = fromMaybe def .^ zipExactMay
-zipWithExactNote :: String -> (a -> b -> c) -> [a] -> [b] -> [c]
-zipWithExactNote note f = zipWithExact_ (addNote note "zipWithExactNote") [] (\a b xs -> f a b : xs)
+zipWithExactNote :: Partial => String -> (a -> b -> c) -> [a] -> [b] -> [c]
+zipWithExactNote note f xs ys = withFrozenCallStack $ zipWithExact_ (addNote note "zipWithExactNote") [] (\a b xs -> f a b : xs) xs ys
zipWithExactMay :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
zipWithExactMay f = zipWithExact_ (const Nothing) (Just []) (\a b xs -> fmap (f a b :) xs)
zipWithExactDef :: [c] -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithExactDef def = fromMaybe def .^^ zipWithExactMay
+
+
+-- |
+-- > zip3Exact xs ys zs =
+-- > | length xs == length ys && length xs == length zs = zip3 xs ys zs
+-- > | otherwise = error "some message"
+zip3Exact :: Partial => [a] -> [b] -> [c] -> [(a,b,c)]
+zip3Exact xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote "" "zip3Exact") [] (\a b c xs -> (a, b, c) : xs) xs ys zs
+
+-- |
+-- > zipWith3Exact f xs ys zs =
+-- > | length xs == length ys && length xs == length zs = zipWith3 f xs ys zs
+-- > | otherwise = error "some message"
+zipWith3Exact :: Partial => (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
+zipWith3Exact f xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote "" "zipWith3Exact") [] (\a b c xs -> f a b c : xs) xs ys zs
+
+
+zip3ExactNote :: Partial => String -> [a] -> [b] -> [c]-> [(a,b,c)]
+zip3ExactNote note xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote note "zip3ExactNote") [] (\a b c xs -> (a,b,c) : xs) xs ys zs
+
+zip3ExactMay :: [a] -> [b] -> [c] -> Maybe [(a,b,c)]
+zip3ExactMay = zipWith3Exact_ (const Nothing) (Just []) (\a b c xs -> fmap ((a,b,c) :) xs)
+
+zip3ExactDef :: [(a,b,c)] -> [a] -> [b] -> [c] -> [(a,b,c)]
+zip3ExactDef def = fromMaybe def .^^ zip3ExactMay
+
+zipWith3ExactNote :: Partial => String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
+zipWith3ExactNote note f xs ys zs = withFrozenCallStack $ zipWith3Exact_ (addNote note "zipWith3ExactNote") [] (\a b c xs -> f a b c : xs) xs ys zs
+
+zipWith3ExactMay :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> Maybe [d]
+zipWith3ExactMay f = zipWith3Exact_ (const Nothing) (Just []) (\a b c xs -> fmap (f a b c :) xs)
+
+zipWith3ExactDef :: [d] -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
+zipWith3ExactDef def = fromMaybe def .^^^ zipWith3ExactMay
diff --git a/Safe/Foldable.hs b/Safe/Foldable.hs
--- a/Safe/Foldable.hs
+++ b/Safe/Foldable.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
{- |
'Foldable' functions, with wrappers like the "Safe" module.
-}
@@ -8,81 +10,123 @@
foldl1May, foldl1Def, foldl1Note,
foldr1May, foldr1Def, foldr1Note,
findJustDef, findJustNote,
- minimumMay, minimumDef, minimumNote,
- maximumMay, maximumDef, maximumNote,
- minimumByMay, minimumByDef, minimumByNote,
- maximumByMay, maximumByDef, maximumByNote,
+ minimumMay, minimumNote,
+ maximumMay, maximumNote,
+ minimumByMay, minimumByNote,
+ maximumByMay, maximumByNote,
+ maximumBoundBy, minimumBoundBy,
+ maximumBounded, maximumBound,
+ minimumBounded, minimumBound,
+ -- * Discouraged
+ minimumDef, maximumDef, minimumByDef, maximumByDef,
-- * Deprecated
- foldl1Safe, foldr1Safe, findJustSafe
+ foldl1Safe, foldr1Safe, findJustSafe,
) where
import Safe.Util
import Data.Foldable as F
-import Data.Monoid
import Data.Maybe
+import Data.Monoid
+import Prelude
+import Safe.Partial
---------------------------------------------------------------------
-- UTILITIES
+fromNote :: Partial => String -> String -> Maybe a -> a
fromNote = fromNoteModule "Safe.Foldable"
-isNull :: Foldable t => t a -> Bool
-isNull = null . toList
-
---------------------------------------------------------------------
-- WRAPPERS
foldl1May, foldr1May :: Foldable t => (a -> a -> a) -> t a -> Maybe a
-foldl1May = liftMay isNull . F.foldl1
-foldr1May = liftMay isNull . F.foldr1
-
-foldl1Note, foldr1Note :: Foldable t => String -> (a -> a -> a) -> t a -> a
-foldl1Note note = fromNote note "foldl1Note on empty" .^ foldl1May
-foldr1Note note = fromNote note "foldr1Note on empty" .^ foldr1May
+foldl1May = liftMay F.null . F.foldl1
+foldr1May = liftMay F.null . F.foldr1
-foldl1Def, foldr1Def :: Foldable t => a -> (a -> a -> a) -> t a -> a
-foldl1Def def = fromMaybe def .^ foldl1May
-foldr1Def def = fromMaybe def .^ foldr1May
+foldl1Note, foldr1Note :: (Partial, Foldable t) => String -> (a -> a -> a) -> t a -> a
+foldl1Note note f x = withFrozenCallStack $ fromNote note "foldl1Note on empty" $ foldl1May f x
+foldr1Note note f x = withFrozenCallStack $ fromNote note "foldr1Note on empty" $ foldr1May f x
minimumMay, maximumMay :: (Foldable t, Ord a) => t a -> Maybe a
-minimumMay = liftMay isNull F.minimum
-maximumMay = liftMay isNull F.maximum
+minimumMay = liftMay F.null F.minimum
+maximumMay = liftMay F.null F.maximum
-minimumDef, maximumDef :: (Foldable t, Ord a) => a -> t a -> a
-minimumDef def = fromMaybe def . minimumMay
-maximumDef def = fromMaybe def . maximumMay
+minimumNote, maximumNote :: (Partial, Foldable t, Ord a) => String -> t a -> a
+minimumNote note x = withFrozenCallStack $ fromNote note "minimumNote on empty" $ minimumMay x
+maximumNote note x = withFrozenCallStack $ fromNote note "maximumNote on empty" $ maximumMay x
-minimumNote, maximumNote :: (Foldable t, Ord a) => String -> t a -> a
-minimumNote note = fromNote note "minimumNote on empty" . minimumMay
-maximumNote note = fromNote note "maximumNote on empty" . maximumMay
+minimumByMay, maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a
+minimumByMay = liftMay F.null . F.minimumBy
+maximumByMay = liftMay F.null . F.maximumBy
-minimumByMay, maximumByMay :: (Foldable t, Ord a) => (a -> a -> Ordering) -> t a -> Maybe a
-minimumByMay = liftMay isNull . F.minimumBy
-maximumByMay = liftMay isNull . F.maximumBy
+minimumByNote, maximumByNote :: (Partial, Foldable t) => String -> (a -> a -> Ordering) -> t a -> a
+minimumByNote note f x = withFrozenCallStack $ fromNote note "minimumByNote on empty" $ minimumByMay f x
+maximumByNote note f x = withFrozenCallStack $ fromNote note "maximumByNote on empty" $ maximumByMay f x
-minimumByDef, maximumByDef :: (Foldable t, Ord a) => a -> (a -> a -> Ordering) -> t a -> a
-minimumByDef def = fromMaybe def .^ minimumByMay
-maximumByDef def = fromMaybe def .^ maximumByMay
+-- | The largest element of a foldable structure with respect to the
+-- given comparison function. The result is bounded by the value given as the first argument.
+maximumBoundBy :: Foldable f => a -> (a -> a -> Ordering) -> f a -> a
+maximumBoundBy x f xs = maximumBy f $ x : toList xs
-minimumByNote, maximumByNote :: (Foldable t, Ord a) => String -> (a -> a -> Ordering) -> t a -> a
-minimumByNote note = fromNote note "minimumByNote on empty" .^ minimumByMay
-maximumByNote note = fromNote note "maximumByNote on empty" .^ maximumByMay
+-- | The smallest element of a foldable structure with respect to the
+-- given comparison function. The result is bounded by the value given as the first argument.
+minimumBoundBy :: Foldable f => a -> (a -> a -> Ordering) -> f a -> a
+minimumBoundBy x f xs = minimumBy f $ x : toList xs
+-- | The largest element of a foldable structure.
+-- The result is bounded by the value given as the first argument.
+maximumBound :: (Foldable f, Ord a) => a -> f a -> a
+maximumBound x xs = maximum $ x : toList xs
+
+-- | The smallest element of a foldable structure.
+-- The result is bounded by the value given as the first argument.
+minimumBound :: (Foldable f, Ord a) => a -> f a -> a
+minimumBound x xs = minimum $ x : toList xs
+
+-- | The largest element of a foldable structure.
+-- The result is bounded by 'minBound'.
+maximumBounded :: (Foldable f, Ord a, Bounded a) => f a -> a
+maximumBounded = maximumBound minBound
+
+-- | The largest element of a foldable structure.
+-- The result is bounded by 'maxBound'.
+minimumBounded :: (Foldable f, Ord a, Bounded a) => f a -> a
+minimumBounded = minimumBound maxBound
+
-- |
-- > findJust op = fromJust . find op
-findJust :: Foldable t => (a -> Bool) -> t a -> a
-findJust = fromNote "" "findJust, no matching value" .^ F.find
+findJust :: (Partial, Foldable t) => (a -> Bool) -> t a -> a
+findJust f x = withFrozenCallStack $ fromNote "" "findJust, no matching value" $ F.find f x
findJustDef :: Foldable t => a -> (a -> Bool) -> t a -> a
findJustDef def = fromMaybe def .^ F.find
-findJustNote :: Foldable t => String -> (a -> Bool) -> t a -> a
-findJustNote note = fromNote note "findJustNote, no matching value" .^ F.find
+findJustNote :: (Partial, Foldable t) => String -> (a -> Bool) -> t a -> a
+findJustNote note f x = withFrozenCallStack $ fromNote note "findJustNote, no matching value" $ F.find f x
---------------------------------------------------------------------
+-- DISCOURAGED
+
+-- | New users are recommended to use 'minimumBound' or 'maximumBound' instead.
+minimumDef, maximumDef :: (Foldable t, Ord a) => a -> t a -> a
+minimumDef def = fromMaybe def . minimumMay
+maximumDef def = fromMaybe def . maximumMay
+
+-- | New users are recommended to use 'minimumBoundBy' or 'maximumBoundBy' instead.
+minimumByDef, maximumByDef :: Foldable t => a -> (a -> a -> Ordering) -> t a -> a
+minimumByDef def = fromMaybe def .^ minimumByMay
+maximumByDef def = fromMaybe def .^ maximumByMay
+
+-- | New users are recommended to use 'foldr1May' or 'foldl1May' instead.
+foldl1Def, foldr1Def :: Foldable t => a -> (a -> a -> a) -> t a -> a
+foldl1Def def = fromMaybe def .^ foldl1May
+foldr1Def def = fromMaybe def .^ foldr1May
+
+
+---------------------------------------------------------------------
-- DEPRECATED
{-# DEPRECATED foldl1Safe "Use @foldl f mempty@ instead." #-}
@@ -92,7 +136,6 @@
{-# DEPRECATED foldr1Safe "Use @foldr f mempty@ instead." #-}
foldr1Safe :: (Monoid m, Foldable t) => (m -> m -> m) -> t m -> m
foldr1Safe fun = F.foldr fun mempty
-
{-# DEPRECATED findJustSafe "Use @findJustDef mempty@ instead." #-}
findJustSafe :: (Monoid m, Foldable t) => (m -> Bool) -> t m -> m
diff --git a/Safe/Partial.hs b/Safe/Partial.hs
new file mode 100644
--- /dev/null
+++ b/Safe/Partial.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ImplicitParams #-}
+
+-- | ConstraintKind synonym for marking partial functions
+module Safe.Partial(Partial) where
+
+-- Let things work through ghci alone
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
+-- GHC has changed its opinion on the location a few times
+-- v0: GHC 7.4.1, has ConstraintKinds
+-- v1: GHC 7.10.2, base 4.8.1.0 = CallStack
+-- v2: GHC 8.0.1, base 4.9.0.0 = HasCallStack
+
+#if __GLASGOW_HASKELL__ >= 800
+#define OPTION 2
+#elif __GLASGOW_HASKELL__ >= 710 && MIN_VERSION_base(4,8,1)
+#define OPTION 1
+#else
+#define OPTION 0
+#endif
+
+
+#if OPTION == 0
+import GHC.Exts
+#else
+import GHC.Stack
+#endif
+
+-- | A constraint synonym which denotes that the function is partial, and will
+-- (on GHC 8.* and up) produce a stack trace on failure.
+-- You may mark your own non-total functions as Partial, if necessary, and this
+-- will ensure that they produce useful stack traces.
+#if OPTION == 0
+type Partial = (() :: Constraint)
+#elif OPTION == 1
+type Partial = (?loc :: CallStack)
+#else
+type Partial = HasCallStack
+#endif
diff --git a/Safe/Util.hs b/Safe/Util.hs
--- a/Safe/Util.hs
+++ b/Safe/Util.hs
@@ -1,24 +1,45 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
-- | Internal utilities.
-module Safe.Util where
+module Safe.Util(
+ fromNoteModule, fromNoteEitherModule,
+ liftMay,
+ (.^), (.^^), (.^^^),
+ eitherToMaybe,
+ withFrozenCallStack
+ ) where
import Data.Maybe
+import Safe.Partial
+-- Let things work through ghci alone
+#if __GLASGOW_HASKELL__ >= 800
+import GHC.Stack
+#else
+withFrozenCallStack :: a -> a
+withFrozenCallStack = id
+#endif
-(.^) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
+
+(.^) :: Partial => (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.^) f g x1 x2 = f (g x1 x2)
-(.^^) :: (b -> c) -> (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> c
+(.^^) :: Partial => (b -> c) -> (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> c
(.^^) f g x1 x2 x3 = f (g x1 x2 x3)
+(.^^^) :: Partial => (b -> c) -> (a1 -> a2 -> a3 -> a4 -> b) -> a1 -> a2 -> a3 -> a4 -> c
+(.^^^) f g x1 x2 x3 x4 = f (g x1 x2 x3 x4)
+
liftMay :: (a -> Bool) -> (a -> b) -> (a -> Maybe b)
liftMay test func val = if test val then Nothing else Just $ func val
-fromNoteModule :: String -> String -> String -> Maybe a -> a
+fromNoteModule :: Partial => String -> String -> String -> Maybe a -> a
fromNoteModule modu note func = fromMaybe (error msg)
where msg = modu ++ "." ++ func ++ (if null note then "" else ", " ++ note)
-fromNoteEitherModule :: String -> String -> String -> Either String a -> a
+fromNoteEitherModule :: Partial => String -> String -> String -> Either String a -> a
fromNoteEitherModule modu note func = either (error . msg) id
where msg ex = modu ++ "." ++ func ++ " " ++ ex ++ (if null note then "" else ", " ++ note)
diff --git a/Test.hs b/Test.hs
new file mode 100644
--- /dev/null
+++ b/Test.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- In the test suite, so OK
+
+module Main(main) where
+
+import Safe
+import Safe.Exact
+import qualified Safe.Foldable as F
+
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import System.IO.Unsafe
+import Test.QuickCheck.Test
+import Test.QuickCheck hiding ((===))
+
+
+---------------------------------------------------------------------
+-- TESTS
+
+main :: IO ()
+main = do
+ -- All from the docs, so check they match
+ tailMay dNil === Nothing
+ tailMay [1,3,4] === Just [3,4]
+ tailDef [12] [] === [12]
+ tailDef [12] [1,3,4] === [3,4]
+ tailNote "help me" dNil `err` "Safe.tailNote [], help me"
+ tailNote "help me" [1,3,4] === [3,4]
+ tailSafe [] === dNil
+ tailSafe [1,3,4] === [3,4]
+
+ findJust (== 2) [d1,2,3] === 2
+ findJust (== 4) [d1,2,3] `err` "Safe.findJust"
+ F.findJust (== 2) [d1,2,3] === 2
+ F.findJust (== 4) [d1,2,3] `err` "Safe.Foldable.findJust"
+ F.findJustDef 20 (== 4) [d1,2,3] === 20
+ F.findJustNote "my note" (== 4) [d1,2,3] `errs` ["Safe.Foldable.findJustNote","my note"]
+
+ takeExact 3 [d1,2] `errs` ["Safe.Exact.takeExact","index=3","length=2"]
+ takeExact (-1) [d1,2] `errs` ["Safe.Exact.takeExact","negative","index=-1"]
+ takeExact 1 (takeExact 3 [d1,2]) === [1] -- test is lazy
+
+ quickCheck_ $ \(Int10 i) (List10 (xs :: [Int])) -> do
+ let (t,d) = splitAt i xs
+ let good = length t == i
+ let f name exact may note res =
+ if good then do
+ exact i xs === res
+ note "foo" i xs === res
+ may i xs === Just res
+ else do
+ exact i xs `err` ("Safe.Exact." ++ name ++ "Exact")
+ note "foo" i xs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
+ may i xs === Nothing
+ f "take" takeExact takeExactMay takeExactNote t
+ f "drop" dropExact dropExactMay dropExactNote d
+ f "splitAt" splitAtExact splitAtExactMay splitAtExactNote (t, d)
+ return True
+
+ take 2 (zipExact [1,2,3] [1,2]) === [(1,1),(2,2)]
+ zipExact [d1,2,3] [d1,2] `errs` ["Safe.Exact.zipExact","first list is longer than the second"]
+ zipExact [d1,2] [d1,2,3] `errs` ["Safe.Exact.zipExact","second list is longer than the first"]
+ zipExact dNil dNil === []
+
+ predMay (minBound :: Int) === Nothing
+ succMay (maxBound :: Int) === Nothing
+ predMay ((minBound + 1) :: Int) === Just minBound
+ succMay ((maxBound - 1) :: Int) === Just maxBound
+
+ quickCheck_ $ \(List10 (xs :: [Int])) x -> do
+ let ys = maybeToList x ++ xs
+ let res = zip xs ys
+ let f name exact may note =
+ if isNothing x then do
+ exact xs ys === res
+ note "foo" xs ys === res
+ may xs ys === Just res
+ else do
+ exact xs ys `err` ("Safe.Exact." ++ name ++ "Exact")
+ note "foo" xs ys `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
+ may xs ys === Nothing
+ f "zip" zipExact zipExactMay zipExactNote
+ f "zipWith" (zipWithExact (,)) (zipWithExactMay (,)) (`zipWithExactNote` (,))
+ return True
+
+ take 2 (zip3Exact [1,2,3] [1,2,3] [1,2]) === [(1,1,1),(2,2,2)]
+ zip3Exact [d1,2] [d1,2,3] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","first list is shorter than the others"]
+ zip3Exact [d1,2,3] [d1,2] [d1,2,3] `errs` ["Safe.Exact.zip3Exact","second list is shorter than the others"]
+ zip3Exact [d1,2,3] [d1,2,3] [d1,2] `errs` ["Safe.Exact.zip3Exact","third list is shorter than the others"]
+ zip3Exact dNil dNil dNil === []
+
+ quickCheck_ $ \(List10 (xs :: [Int])) x1 x2 -> do
+ let ys = maybeToList x1 ++ xs
+ let zs = maybeToList x2 ++ xs
+ let res = zip3 xs ys zs
+ let f name exact may note =
+ if isNothing x1 && isNothing x2 then do
+ exact xs ys zs === res
+ note "foo" xs ys zs === res
+ may xs ys zs === Just res
+ else do
+ exact xs ys zs `err` ("Safe.Exact." ++ name ++ "Exact")
+ note "foo" xs ys zs `errs` ["Safe.Exact." ++ name ++ "ExactNote","foo"]
+ may xs ys zs === Nothing
+ f "zip3" zip3Exact zip3ExactMay zip3ExactNote
+ f "zipWith3" (zipWith3Exact (,,)) (zipWith3ExactMay (,,)) (flip zipWith3ExactNote (,,))
+ return True
+
+
+---------------------------------------------------------------------
+-- UTILITIES
+
+quickCheck_ prop = do
+ r <- quickCheckResult prop
+ unless (isSuccess r) $ error "Test failed"
+
+
+d1 = 1 :: Double
+dNil = [] :: [Double]
+
+(===) :: (Show a, Eq a) => a -> a -> IO ()
+(===) a b = when (a /= b) $ error $ "Mismatch: " ++ show a ++ " /= " ++ show b
+
+err :: NFData a => a -> String -> IO ()
+err a b = errs a [b]
+
+errs :: NFData a => a -> [String] -> IO ()
+errs a bs = do
+ res <- try $ evaluate $ rnf a
+ case res of
+ Right v -> error $ "Expected error, but succeeded: " ++ show bs
+ Left (msg :: SomeException) -> forM_ bs $ \b -> do
+ let s = show msg
+ unless (b `isInfixOf` s) $ error $ "Invalid error string, got " ++ show s ++ ", want " ++ show b
+ let f xs = " " ++ map (\x -> if sepChar x then ' ' else x) xs ++ " "
+ unless (f b `isInfixOf` f s) $ error $ "Not standalone error string, got " ++ show s ++ ", want " ++ show b
+
+sepChar x = isSpace x || x `elem` ",;."
+
+newtype Int10 = Int10 Int deriving Show
+
+instance Arbitrary Int10 where
+ arbitrary = fmap Int10 $ choose (-3, 10)
+
+newtype List10 a = List10 [a] deriving Show
+
+instance Arbitrary a => Arbitrary (List10 a) where
+ arbitrary = do i <- choose (0, 10); fmap List10 $ vector i
+
+instance Testable a => Testable (IO a) where
+ property = property . unsafePerformIO
diff --git a/safe.cabal b/safe.cabal
--- a/safe.cabal
+++ b/safe.cabal
@@ -1,17 +1,17 @@
-cabal-version: >= 1.6
+cabal-version: 1.18
build-type: Simple
name: safe
-version: 0.3.7
+version: 0.3.21
license: BSD3
license-file: LICENSE
category: Unclassified
author: Neil Mitchell
maintainer: Neil Mitchell
-copyright: Neil Mitchell 2007-2014
-homepage: http://community.haskell.org/~ndm/safe/
+copyright: Neil Mitchell 2007-2024
+homepage: https://github.com/ndmitchell/safe#readme
synopsis: Library of safe (exception free) functions
bug-reports: https://github.com/ndmitchell/safe/issues
-tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2
+tested-with: GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8
description:
A library wrapping @Prelude@/@Data.List@ functions that can throw exceptions, such as @head@ and @!!@.
Each unsafe function has up to four variants, e.g. with @tail@:
@@ -33,21 +33,41 @@
* "Safe.Foldable" contains safe variants of @Foldable@ functions.
.
* "Safe.Exact" creates crashing versions of functions like @zip@ (errors if the lists are not equal) and @take@ (errors if there are not enough elements), then wraps them to provide safe variants.
-extra-source-files:
+extra-doc-files:
CHANGES.txt
+ README.md
source-repository head
type: git
location: https://github.com/ndmitchell/safe.git
library
+ default-language: Haskell2010
build-depends:
- base < 5
+ base >= 4.8 && < 5
exposed-modules:
Safe
Safe.Exact
Safe.Foldable
+ Safe.Partial
other-modules:
Safe.Util
+
+test-suite safe-test
+ type: exitcode-stdio-1.0
+ main-is: Test.hs
+ default-language: Haskell2010
+
+ other-modules:
+ Safe
+ Safe.Exact
+ Safe.Foldable
+ Safe.Partial
+ Safe.Util
+ build-depends:
+ base,
+ deepseq,
+ QuickCheck,
+ safe