diff --git a/CHANGES.txt b/CHANGES.txt
new file mode 100644
--- /dev/null
+++ b/CHANGES.txt
@@ -0,0 +1,58 @@
+Changelog for Safe
+
+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, released 2014-07-12
+ #6, remove unnecessary Ord constraints from maximumBy/minimumBy
+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, released 2014-01-30
+ #1, improve the string clipping in readNote
+0.3.3, released 2011-11-15
+ #494, add foldl1' wrappings
+0.3.2, released 2011-11-13
+ Add a Safe.Foldable module
+0.3.1, released 2011-11-09
+ Add findJust, safe wrapping of fromJust/find
+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-2008.
+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,254 +1,417 @@
-
-{- |
-Module : Safe
-Copyright : (c) Neil Mitchell 2007-2008
-License : BSD3
-
-Maintainer : http://www.cs.york.ac.uk/~ndm/
-Stability : in-progress
-Portability : portable
-
-A library for safe functions, based on standard functions that may crash.
-For more details see
-
-In general, each unsafe function has up to 4 forms.
-Since 'tail' has all the possible forms, it is fully documented.
-The others all follow the same pattern.
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}
-* @Note@, takes an extra argument which supplements the error message, 'tailNote'
+{- |
+A module wrapping @Prelude@/@Data.List@ functions that can throw exceptions, such as @head@ and @!!@.
+Each unsafe function has up to five variants, e.g. with @tail@:
-* @Def@, take an extra argument to give when a crash would otherwise happen, 'tailDef'
+* @'tail' :: [a] -> [a]@, raises an error on @tail []@, as provided by 'Prelude'.
-* @May@, wraps the result in a Maybe, 'tailMay'
+* @'tailErr' :: [a] -> [a]@, alias for @tail@ that doesn't trigger an @x-partial@ warning and does raise errors.
-* @Safe@, returns a default type if possible, 'tailSafe'
+* @'tailMay' :: [a] -> /Maybe/ [a]@, turns errors into @Nothing@.
-This library also introduces three brand new functions:
+* @'tailDef' :: /[a]/ -> [a] -> [a]@, takes a default to return on errors.
-* 'at' - synonym for @(!!)@
+* @'tailNote' :: 'Partial' => /String/ -> [a] -> [a]@, takes an extra argument which supplements the error message.
-* 'lookupJust' - defined as @lookupJust k = fromJust . lookup k@
+* @'tailSafe' :: [a] -> [a]@, returns some sensible default if possible, @[]@ in the case of @tail@.
-* 'abort' - same as @error@, but different intended meaning
+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(
- tailDef, tailMay, tailNote, tailSafe,
- initDef, initMay, initNote, initSafe,
- headDef, headMay, headNote,
- lastDef, lastMay, lastNote,
- minimumDef, minimumMay, minimumNote,
- maximumDef, maximumMay, maximumNote,
- foldr1Def, foldr1May, foldr1Note,
- foldl1Def, foldl1May, foldl1Note,
+ -- * 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, 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,
- at, atDef, atMay, atNote,
- readDef, readMay, readNote,
- lookupJust, lookupJustDef, lookupJustNote,
- abort
+ atMay, atDef, atNote,
+ 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
-{-# PARTIAL tailNote, initNote, headNote, lastNote, minimumNote, maximumNote #-}
-{-# PARTIAL foldr1Note, foldl1Note, fromJustNote, assertNote, at, atNote, readNote #-}
-{-# PARTIAL lookupJustNote, lookupJust #-}
+---------------------------------------------------------------------
+-- UTILITIES
+fromNote :: Partial => String -> String -> Maybe a -> a
+fromNote = fromNoteModule "Safe"
-liftDef :: (a -> b) -> (a -> Bool) -> b -> (a -> b)
-liftDef func test def val = if test val then def else func val
+fromNoteEither :: Partial => String -> String -> Either String a -> a
+fromNoteEither = fromNoteEitherModule "Safe"
-liftMay :: (a -> b) -> (a -> Bool) -> (a -> Maybe b)
-liftMay func test val = if test val then Nothing else Just $ func val
-liftNote :: (a -> b) -> (a -> Bool) -> String -> String -> (a -> b)
-liftNote func test caller note val =
- if test val
- then error $ "Pattern match failure, " ++ caller ++ ", " ++ note
- else func val
+---------------------------------------------------------------------
+-- IMPLEMENTATIONS
-liftSafe :: (a -> a) -> (a -> Bool) -> (a -> a)
-liftSafe func test val = if test val then val else func val
+-- | 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 :: Partial => String -> a
+abort x = withFrozenCallStack (error x)
--- |
--- > tailDef [12] [] = [12]
--- > tailDef [12] [1,3,4] = [3,4]
-tailDef :: [a] -> [a] -> [a]
-tailDef = liftDef tail null
+at_ :: [a] -> Int -> Either String a
+at_ xs o | o < 0 = Left $ "index must not be negative, index=" ++ show o
+ | otherwise = f o xs
+ where f 0 (x:xs) = Right x
+ f i (x:xs) = f (i-1) xs
+ f i [] = Left $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
+
+---------------------------------------------------------------------
+-- 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 tail null
+tailMay :: [a] -> Maybe [a]
+tailMay [] = Nothing
+tailMay (_:xs) = Just xs
-- |
--- > tail "help me" [] = error "Pattern match failure, tail [], help me"
--- > tail "help me" [1,3,4] = [3,4]
-tailNote :: String -> [a] -> [a]
-tailNote = liftNote tail null "tail []"
+-- > tailDef [12] [] = [12]
+-- > tailDef [12] [1,3,4] = [3,4]
+tailDef :: [a] -> [a] -> [a]
+tailDef def = fromMaybe def . tailMay
-- |
+-- > tailNote "help me" [] = error "Safe.tailNote [], help me"
+-- > tailNote "help me" [1,3,4] = [3,4]
+tailNote :: Partial => String -> [a] -> [a]
+tailNote note x = withFrozenCallStack $ fromNote note "tailNote []" $ tailMay x
+
+-- |
-- > tailSafe [] = []
-- > tailSafe [1,3,4] = [3,4]
tailSafe :: [a] -> [a]
-tailSafe = liftSafe tail null
+tailSafe = tailDef []
-initDef :: [a] -> [a] -> [a]
-initDef = liftDef init null
+initMay :: [a] -> Maybe [a]
+initMay = liftMay null init
-initMay :: [a] -> Maybe [a]
-initMay = liftMay init null
+initDef :: [a] -> [a] -> [a]
+initDef def = fromMaybe def . initMay
-initNote :: String -> [a] -> [a]
-initNote = liftNote init null "init []"
+initNote :: Partial => String -> [a] -> [a]
+initNote note x = withFrozenCallStack $ fromNote note "initNote []" $ initMay x
initSafe :: [a] -> [a]
-initSafe = liftSafe init null
+initSafe = initDef []
-headDef :: a -> [a] -> a
-headDef = liftDef head null
-
-headMay :: [a] -> Maybe a
-headMay = liftMay head null
+headMay, lastMay :: [a] -> Maybe a
+headMay = listToMaybe
+lastMay = liftMay null last
-headNote :: String -> [a] -> a
-headNote = liftNote head null "head []"
+headDef, lastDef :: a -> [a] -> a
+headDef def = fromMaybe def . headMay
+lastDef def = fromMaybe def . 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
-lastDef :: a -> [a] -> a
-lastDef = liftDef last null
+minimumMay, maximumMay :: Ord a => [a] -> Maybe a
+minimumMay = liftMay null minimum
+maximumMay = liftMay null maximum
-lastMay :: [a] -> Maybe a
-lastMay = liftMay last null
+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
-lastNote :: String -> [a] -> a
-lastNote = liftNote last null "last []"
+minimumByMay, maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
+minimumByMay = liftMay null . minimumBy
+maximumByMay = liftMay null . maximumBy
+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
+-- | 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
-minimumDef :: Ord a => a -> [a] -> a
-minimumDef = liftDef minimum null
+-- | 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
-minimumMay :: Ord a => [a] -> Maybe a
-minimumMay = liftMay minimum null
+-- | 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
-minimumNote :: Ord a => String -> [a] -> a
-minimumNote = liftNote minimum null "minimum []"
+-- | 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
-maximumDef :: Ord a => a -> [a] -> a
-maximumDef = liftDef maximum null
+-- | The largest element of a list.
+-- The result is bounded by 'maxBound'.
+minimumBounded :: (Ord a, Bounded a) => [a] -> a
+minimumBounded = minimumBound maxBound
-maximumMay :: Ord a => [a] -> Maybe a
-maximumMay = liftMay maximum null
+foldr1May, foldl1May, foldl1May' :: (a -> a -> a) -> [a] -> Maybe a
+foldr1May = liftMay null . foldr1
+foldl1May = liftMay null . foldl1
+foldl1May' = liftMay null . foldl1'
-maximumNote :: Ord a => String -> [a] -> a
-maximumNote = liftNote maximum null "maximum []"
+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
+scanl1May = liftMay null . scanl1
+scanr1Def, scanl1Def :: [a] -> (a -> a -> a) -> [a] -> [a]
+scanr1Def def = fromMaybe def .^ scanr1May
+scanl1Def def = fromMaybe def .^ scanl1May
-foldr1Def :: a -> (a -> a -> a) -> [a] -> a
-foldr1Def def f = liftDef (foldr1 f) null def
+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
-foldr1May :: (a -> a -> a) -> [a] -> Maybe a
-foldr1May f = liftMay (foldr1 f) null
+cycleMay :: [a] -> Maybe [a]
+cycleMay = liftMay null cycle
-foldr1Note :: String -> (a -> a -> a) -> [a] -> a
-foldr1Note note f = liftNote (foldr1 f) null "foldr1 []" note
+cycleDef :: [a] -> [a] -> [a]
+cycleDef def = fromMaybe def . cycleMay
+cycleNote :: Partial => String -> [a] -> [a]
+cycleNote note x = withFrozenCallStack $ fromNote note "cycleNote []" $ cycleMay x
-foldl1Def :: a -> (a -> a -> a) -> [a] -> a
-foldl1Def def f = liftDef (foldl1 f) null def
+-- | 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
-foldl1May :: (a -> a -> a) -> [a] -> Maybe a
-foldl1May f = liftMay (foldl1 f) null
+fromJustNote :: Partial => String -> Maybe a -> a
+fromJustNote note x = withFrozenCallStack $ fromNote note "fromJustNote Nothing" x
-foldl1Note :: String -> (a -> a -> a) -> [a] -> a
-foldl1Note note f = liftNote (foldl1 f) null "foldl1 []" note
+assertNote :: Partial => String -> Bool -> a -> a
+assertNote note True val = val
+assertNote note False val = withFrozenCallStack $ fromNote note "assertNote False" Nothing
--- | See fromMaybe
-fromJustDef :: a -> Maybe a -> a
-fromJustDef = liftDef fromJust isNothing
+-- | Synonym for '!!', but includes more information in the error message.
+at :: Partial => [a] -> Int -> a
+at = fromNoteEither "" "at" .^ at_
-fromJustNote :: String -> Maybe a -> a
-fromJustNote = liftNote fromJust isNothing "fromJust Nothing"
+atMay :: [a] -> Int -> Maybe a
+atMay = eitherToMaybe .^ at_
+atDef :: a -> [a] -> Int -> a
+atDef def = fromMaybe def .^ atMay
+atNote :: Partial => String -> [a] -> Int -> a
+atNote note f x = withFrozenCallStack $ fromNoteEither note "atNote" $ at_ f x
-assertNote :: String -> Bool -> a -> a
-assertNote msg False val = error $ "assertion failed, " ++ msg
-assertNote msg True val = val
+-- | 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 . readEitherSafe
+readDef :: Read a => a -> String -> a
+readDef def = fromMaybe def . readMay
--- | Same as @(!!)@, but better error message
-at :: [a] -> Int -> a
-at = atNote "called by at"
+-- | 'readNote' uses 'readEitherSafe' for the error message.
+readNote :: (Partial, Read a) => String -> String -> a
+readNote note x = withFrozenCallStack $ fromNoteEither note "readNote" $ readEitherSafe x
-atDef :: a -> [a] -> Int -> a
-atDef def x n = fromMaybe def (atMay x n)
+-- |
+-- > lookupJust key = fromJust . lookup key
+lookupJust :: (Eq a, Partial) => a -> [(a,b)] -> b
+lookupJust x xs = withFrozenCallStack $ fromNote "" "lookupJust, no matching value" $ lookup x xs
-atMay :: [a] -> Int -> Maybe a
-atMay xs n | n < 0 = Nothing
-atMay [] _ = Nothing
-atMay (x:_) 0 = Just x
-atMay (_:xs) n = atMay xs (n-1)
+lookupJustDef :: Eq a => b -> a -> [(a,b)] -> b
+lookupJustDef def = fromMaybe def .^ lookup
-atNote :: String -> [a] -> Int -> a
-atNote msg _ n | n < 0 = error $ "Safe.at: negative index, " ++ msg
-atNote msg xs n = f xs n
- where
- f [] i = error $ "Safe.at: index too large, index=" ++ show n ++ ", length=" ++ show (n-i) ++ ", " ++ msg
- f (x:_) 0 = x
- f (_:xs) i = f xs (i-1)
+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
+findJust :: (a -> Bool) -> [a] -> a
+findJust = fromNote "" "findJust, no matching value" .^ find
+findJustDef :: a -> (a -> Bool) -> [a] -> a
+findJustDef def = fromMaybe def .^ find
-readDef :: Read a => a -> String -> a
-readDef def s = fromMaybe def (readMay s)
+findJustNote :: Partial => String -> (a -> Bool) -> [a] -> a
+findJustNote note f x = withFrozenCallStack $ fromNote note "findJustNote, no matching value" $ find f x
-readMay :: Read a => String -> Maybe a
-readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> Just x
- _ -> Nothing
+-- |
+-- > elemIndexJust op = fromJust . elemIndex op
+elemIndexJust :: (Partial, Eq a) => a -> [a] -> Int
+elemIndexJust x xs = withFrozenCallStack $ fromNote "" "elemIndexJust, no matching value" $ elemIndex x xs
-readNote :: Read a => String -> String -> a
-readNote msg s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> x
- [] -> error $ "Prelude.read: no parse, " ++ msg ++ ", on " ++ prefix
- _ -> error $ "Prelude.read: ambiguous parse, " ++ msg ++ ", on " ++ prefix
- where
- prefix = '\"' : a ++ if null b then "\"" else "..."
- where (a,b) = splitAt 10 s
+elemIndexJustDef :: Eq a => Int -> a -> [a] -> Int
+elemIndexJustDef def = fromMaybe def .^ elemIndex
+elemIndexJustNote :: (Partial, Eq a) => String -> a -> [a] -> Int
+elemIndexJustNote note x xs = withFrozenCallStack $ fromNote note "elemIndexJustNote, no matching value" $ elemIndex x xs
-- |
--- > lookupJust key = fromJust . lookup key
-lookupJust :: Eq a => a -> [(a,b)] -> b
-lookupJust key = fromJustNote "lookupJust, item not found" . lookup key
+-- > findIndexJust op = fromJust . findIndex op
+findIndexJust :: (a -> Bool) -> [a] -> Int
+findIndexJust f x = withFrozenCallStack $ fromNote "" "findIndexJust, no matching value" $ findIndex f x
-lookupJustDef :: Eq a => b -> a -> [(a,b)] -> b
-lookupJustDef def key lst = fromMaybe def (lookup key lst)
+findIndexJustDef :: Int -> (a -> Bool) -> [a] -> Int
+findIndexJustDef def = fromMaybe def .^ findIndex
-lookupJustNote :: Eq a => String -> a -> [(a,b)] -> b
-lookupJustNote msg key lst = case lookup key lst of
- Nothing -> error $ "Safe.lookupJust: element not found, " ++ msg
- Just x -> x
+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
--- | Exactly the same as @error@. Use this for instances where the program
--- has decided to exit because of invalid user input, or the user pressed
--- quit etc. This allows @error@ to be reserved for genuine coding mistakes.
-abort :: String -> a
-abort = error
+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
new file mode 100644
--- /dev/null
+++ b/Safe/Exact.hs
@@ -0,0 +1,206 @@
+{-# 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:
+
+* @'takeExact' 3 [1,2]@ raises an error, in contrast to 'take' which would return
+ just two elements.
+
+* @'takeExact' (-1) [1,2]@ raises an error, in contrast to 'take' which would return
+ no elements.
+
+* @'zip' [1,2] [1]@ raises an error, in contrast to 'zip' which would only pair up the
+ first element.
+
+Note that the @May@ variants of these functions are /strict/ in at least the bit of the prefix
+of the list required to spot errors. The standard and @Note@ versions are lazy, but throw
+errors later in the process - they do not check upfront.
+-}
+module Safe.Exact(
+ -- * 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)
+
+
+---------------------------------------------------------------------
+-- IMPLEMENTATIONS
+
+{-# INLINE splitAtExact_ #-}
+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
+ where
+ f 0 xs = nil xs
+ f i (x:xs) = x `cons` f (i-1) xs
+ f i [] = err $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
+
+
+{-# INLINE zipWithExact_ #-}
+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
+ f [] [] = nil
+ f [] _ = err "second list is longer than the first"
+ 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
+
+-- |
+-- > takeExact n xs =
+-- > | n >= 0 && n <= length xs = take n xs
+-- > | otherwise = error "some message"
+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 :: 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 :: Partial => Int -> [a] -> ([a], [a])
+splitAtExact i xs = withFrozenCallStack $ splitAtExact_ (addNote "" "splitAtExact")
+ ([],) (\a b -> first (a:) b) i xs
+
+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:))
+
+takeExactDef :: [a] -> Int -> [a] -> [a]
+takeExactDef def = fromMaybe def .^ takeExactMay
+
+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 (\_ x -> x)
+
+dropExactDef :: [a] -> Int -> [a] -> [a]
+dropExactDef def = fromMaybe def .^ dropExactMay
+
+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)
+ (\x -> Just ([], x)) (\a b -> fmap (first (a:)) b)
+
+splitAtExactDef :: ([a], [a]) -> Int -> [a] -> ([a], [a])
+splitAtExactDef def = fromMaybe def .^ splitAtExactMay
+
+---------------------------------------------------------------------
+-- ZIP
+
+-- |
+-- > zipExact xs ys =
+-- > | length xs == length ys = zip xs ys
+-- > | otherwise = error "some message"
+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 :: 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 :: 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)
+
+zipExactDef :: [(a,b)] -> [a] -> [b] -> [(a,b)]
+zipExactDef def = fromMaybe def .^ zipExactMay
+
+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
new file mode 100644
--- /dev/null
+++ b/Safe/Foldable.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{- |
+'Foldable' functions, with wrappers like the "Safe" module.
+-}
+module Safe.Foldable(
+ -- * New functions
+ findJust,
+ -- * Safe wrappers
+ foldl1May, foldl1Def, foldl1Note,
+ foldr1May, foldr1Def, foldr1Note,
+ findJustDef, findJustNote,
+ minimumMay, minimumNote,
+ maximumMay, maximumNote,
+ minimumByMay, minimumByNote,
+ maximumByMay, maximumByNote,
+ maximumBoundBy, minimumBoundBy,
+ maximumBounded, maximumBound,
+ minimumBounded, minimumBound,
+ -- * Discouraged
+ minimumDef, maximumDef, minimumByDef, maximumByDef,
+ -- * Deprecated
+ foldl1Safe, foldr1Safe, findJustSafe,
+ ) where
+
+import Safe.Util
+import Data.Foldable as F
+import Data.Maybe
+import Data.Monoid
+import Prelude
+import Safe.Partial
+
+
+---------------------------------------------------------------------
+-- UTILITIES
+
+fromNote :: Partial => String -> String -> Maybe a -> a
+fromNote = fromNoteModule "Safe.Foldable"
+
+
+---------------------------------------------------------------------
+-- WRAPPERS
+
+foldl1May, foldr1May :: Foldable t => (a -> a -> a) -> t a -> Maybe a
+foldl1May = liftMay F.null . F.foldl1
+foldr1May = liftMay F.null . F.foldr1
+
+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 F.null F.minimum
+maximumMay = liftMay F.null F.maximum
+
+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
+
+minimumByMay, maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a
+minimumByMay = liftMay F.null . F.minimumBy
+maximumByMay = liftMay F.null . 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
+
+-- | 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
+
+-- | 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 :: (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 :: (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." #-}
+foldl1Safe :: (Monoid m, Foldable t) => (m -> m -> m) -> t m -> m
+foldl1Safe fun = F.foldl fun mempty
+
+{-# 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
+findJustSafe = findJustDef mempty
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
new file mode 100644
--- /dev/null
+++ b/Safe/Util.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
+
+-- | Internal utilities.
+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
+
+
+(.^) :: Partial => (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
+(.^) f g x1 x2 = f (g x1 x2)
+
+(.^^) :: 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 :: 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 :: 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)
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe = either (const Nothing) Just
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,21 +1,73 @@
-Name: safe
-Build-Type: Simple
-Version: 0.2
-License: BSD3
-License-File: LICENSE
-Copyright: 2007-8, Neil Mitchell
-Maintainer: ndmitchell@gmail.com
-Author: Neil Mitchell
-Homepage: http://www-users.cs.york.ac.uk/~ndm/safe/
-Build-Depends: base
-Category: Unclassified
-Synopsis: Library for safe (pattern match free) functions
-Description:
- Partial functions from the base library, such as @head@ and @!!@, modified
- to return more descriptive error messages, programmer defined error messages,
- @Maybe@ wrapped results and default values.
-
- These functions can be used to reduce the number of unsafe pattern matches in
- your code.
-Exposed-modules:
+cabal-version: 1.18
+build-type: Simple
+name: safe
+version: 0.3.21
+license: BSD3
+license-file: LICENSE
+category: Unclassified
+author: Neil Mitchell
+maintainer: Neil Mitchell
+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==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@:
+ .
+ * @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.
+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 >= 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