diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,9 @@ Changelog for Extra +1.7.9, released 2020-12-19 + #72, add pureIf + #73, make takeEnd, dropEnd, splitAtEnd: return immediately if i <= 0 + #71, add compareLength and comparingLength 1.7.8, released 2020-09-12 #68, make sure Data.Foldable.Extra is exposed 1.7.7, released 2020-08-25 diff --git a/Generate.hs b/Generate.hs --- a/Generate.hs +++ b/Generate.hs @@ -46,11 +46,12 @@ ["-- GENERATED CODE - DO NOT MODIFY" ,"-- See Generate.hs for details of how to generate" ,"" - ,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-}" + ,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, TypeApplications, ViewPatterns #-}" ,"module TestGen(tests) where" ,"import TestUtil" ,"import qualified Data.List" ,"import qualified Data.List.NonEmpty.Extra" + ,"import qualified Data.Ord" ,"import Test.QuickCheck.Instances.Semigroup ()" ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))" ,"tests :: IO ()" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Extra [![Hackage version](https://img.shields.io/hackage/v/extra.svg?label=Hackage)](https://hackage.haskell.org/package/extra) [![Stackage version](https://www.stackage.org/package/extra/badge/nightly?label=Stackage)](https://www.stackage.org/package/extra) [![Linux build status](https://img.shields.io/travis/ndmitchell/extra/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/extra) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/extra/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/extra) +# Extra [![Hackage version](https://img.shields.io/hackage/v/extra.svg?label=Hackage)](https://hackage.haskell.org/package/extra) [![Stackage version](https://www.stackage.org/package/extra/badge/nightly?label=Stackage)](https://www.stackage.org/package/extra) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/extra/ci.svg)](https://github.com/ndmitchell/extra/actions) A library of extra functions for the standard Haskell libraries. Most functions are simple additions, filling out missing functionality. A few functions are available in later versions of GHC, but this package makes them available back to GHC 7.10. A few examples: diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: extra -version: 1.7.8 +version: 1.7.9 license: BSD3 license-file: LICENSE category: Development diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs --- a/src/Control/Concurrent/Extra.hs +++ b/src/Control/Concurrent/Extra.hs @@ -4,13 +4,13 @@ -- -- This module includes three new types of 'MVar', namely 'Lock' (no associated value), -- 'Var' (never empty) and 'Barrier' (filled at most once). See --- +-- -- for examples and justification. -- -- If you need greater control of exceptions and threads -- see the package. -- If you need elaborate relationships between threads --- see the package. +-- see the package. module Control.Concurrent.Extra( module Control.Concurrent, withNumCapabilities, diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs --- a/src/Control/Monad/Extra.hs +++ b/src/Control/Monad/Extra.hs @@ -7,6 +7,7 @@ module Control.Monad.Extra( module Control.Monad, whenJust, whenJustM, + pureIf, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, @@ -40,6 +41,14 @@ -- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative whenJustM mg f = maybeM (pure ()) f mg +-- | Return either a `pure` value if a condition is `True`, otherwise `empty`. +-- +-- > pureIf @Maybe True 5 == Just 5 +-- > pureIf @Maybe False 5 == Nothing +-- > pureIf @[] True 5 == [5] +-- > pureIf @[] False 5 == [] +pureIf :: (Alternative m) => Bool -> a -> m a +pureIf b a = if b then pure a else empty -- | Like 'when', but return either 'Nothing' if the predicate was 'False', -- of 'Just' with the result of the computation. @@ -55,7 +64,6 @@ whenMaybeM mb x = do b <- mb if b then liftM Just x else pure Nothing - -- | The identity function which requires the inner argument to be @()@. Useful for functions -- with overloaded return types. diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -19,7 +19,7 @@ breakOn, breakOnEnd, splitOn, split, chunksOf, -- * Basics headDef, lastDef, notNull, list, unsnoc, cons, snoc, - drop1, dropEnd1, mconcatMap, + drop1, dropEnd1, mconcatMap, compareLength, comparingLength, -- * Enum operations enumerate, -- * List operations @@ -46,6 +46,7 @@ import Data.Monoid import Numeric import Data.Functor +import Data.Foldable import Prelude @@ -198,7 +199,9 @@ -- > \i xs -> takeEnd i xs `isSuffixOf` xs -- > \i xs -> length (takeEnd i xs) == min (max 0 i) (length xs) takeEnd :: Int -> [a] -> [a] -takeEnd i xs = f xs (drop i xs) +takeEnd i xs + | i <= 0 = [] + | otherwise = f xs (drop i xs) where f (x:xs) (y:ys) = f xs ys f xs _ = xs @@ -211,7 +214,9 @@ -- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i) -- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..] dropEnd :: Int -> [a] -> [a] -dropEnd i xs = f xs (drop i xs) +dropEnd i xs + | i <= 0 = xs + | otherwise = f xs (drop i xs) where f (x:xs) (y:ys) = x : f xs ys f _ _ = [] @@ -224,7 +229,9 @@ -- > \i xs -> uncurry (++) (splitAt i xs) == xs -- > \i xs -> splitAtEnd i xs == (dropEnd i xs, takeEnd i xs) splitAtEnd :: Int -> [a] -> ([a], [a]) -splitAtEnd i xs = f xs (drop i xs) +splitAtEnd i xs + | i <= 0 = (xs, []) + | otherwise = f xs (drop i xs) where f (x:xs) (y:ys) = first (x:) $ f xs ys f xs _ = ([], xs) @@ -844,3 +851,26 @@ zipWithLongest f (x:xs) (y:ys) = f (Just x) (Just y) : zipWithLongest f xs ys zipWithLongest f [] ys = map (f Nothing . Just) ys zipWithLongest f xs [] = map ((`f` Nothing) . Just) xs + +-- | Lazily compare the length of a 'Foldable' with a number. +-- +-- > compareLength [1,2,3] 1 == GT +-- > compareLength [1,2] 2 == EQ +-- > \(xs :: [Int]) n -> compareLength xs n == compare (length xs) n +-- > compareLength (1:2:3:undefined) 2 == GT +compareLength :: (Ord b, Num b, Foldable f) => f a -> b -> Ordering +compareLength = foldr (\_ acc n -> if n > 0 then acc (n - 1) else GT) (compare 0) + +-- | Lazily compare the length of two 'Foldable's. +-- > comparingLength [1,2,3] [False] == GT +-- > comparingLength [1,2] "ab" == EQ +-- > \(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys +-- > comparingLength [1,2] (1:2:3:undefined) == LT +-- > comparingLength (1:2:3:undefined) [1,2] == GT +comparingLength :: (Foldable f1, Foldable f2) => f1 a -> f2 b -> Ordering +comparingLength x y = go (toList x) (toList y) + where + go [] [] = EQ + go [] (_:_) = LT + go (_:_) [] = GT + go (_:xs) (_:ys) = go xs ys diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -14,7 +14,7 @@ Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. - whenJust, whenJustM, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, loop, loopM, whileM, whileJustM, untilJustM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, fold1M, fold1M_, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, + whenJust, whenJustM, pureIf, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, loop, loopM, whileM, whileJustM, untilJustM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, fold1M, fold1M_, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, -- * Data.Either.Extra -- | Extra functions available in @"Data.Either.Extra"@. fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither, mapLeft, mapRight, @@ -23,7 +23,7 @@ writeIORef', atomicWriteIORef', atomicModifyIORef_, atomicModifyIORef'_, -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. - lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, sum', product', sumOn', productOn', disjoint, disjointOrd, disjointOrdBy, allSame, anySame, repeatedly, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, zipWithLongest, replace, merge, mergeBy, + lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, compareLength, comparingLength, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, sum', product', sumOn', productOn', disjoint, disjointOrd, disjointOrdBy, allSame, anySame, repeatedly, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, zipWithLongest, replace, merge, mergeBy, -- * Data.List.NonEmpty.Extra -- | Extra functions available in @"Data.List.NonEmpty.Extra"@. (|:), (|>), appendl, appendr, maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1, diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -1,11 +1,12 @@ -- GENERATED CODE - DO NOT MODIFY -- See Generate.hs for details of how to generate -{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, TypeApplications, ViewPatterns #-} module TestGen(tests) where import TestUtil import qualified Data.List import qualified Data.List.NonEmpty.Extra +import qualified Data.Ord import Test.QuickCheck.Instances.Semigroup () default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () @@ -29,6 +30,10 @@ testGen "retry 3 (fail \"die\") == fail \"die\"" $ retry 3 (fail "die") == fail "die" testGen "whenJust Nothing print == pure ()" $ whenJust Nothing print == pure () testGen "whenJust (Just 1) print == print 1" $ whenJust (Just 1) print == print 1 + testGen "pureIf @Maybe True 5 == Just 5" $ pureIf @Maybe True 5 == Just 5 + testGen "pureIf @Maybe False 5 == Nothing" $ pureIf @Maybe False 5 == Nothing + testGen "pureIf @[] True 5 == [5]" $ pureIf @[] True 5 == [5] + testGen "pureIf @[] False 5 == []" $ pureIf @[] False 5 == [] testGen "whenMaybe True (print 1) == fmap Just (print 1)" $ whenMaybe True (print 1) == fmap Just (print 1) testGen "whenMaybe False (print 1) == pure Nothing" $ whenMaybe False (print 1) == pure Nothing testGen "\\(x :: Maybe ()) -> unit x == x" $ \(x :: Maybe ()) -> unit x == x @@ -252,6 +257,15 @@ testGen "zipWithLongest (,) \"a\" \"xyz\" == [(Just 'a', Just 'x'), (Nothing, Just 'y'), (Nothing, Just 'z')]" $ zipWithLongest (,) "a" "xyz" == [(Just 'a', Just 'x'), (Nothing, Just 'y'), (Nothing, Just 'z')] testGen "zipWithLongest (,) \"a\" \"x\" == [(Just 'a', Just 'x')]" $ zipWithLongest (,) "a" "x" == [(Just 'a', Just 'x')] testGen "zipWithLongest (,) \"\" \"x\" == [(Nothing, Just 'x')]" $ zipWithLongest (,) "" "x" == [(Nothing, Just 'x')] + testGen "compareLength [1,2,3] 1 == GT" $ compareLength [1,2,3] 1 == GT + testGen "compareLength [1,2] 2 == EQ" $ compareLength [1,2] 2 == EQ + testGen "\\(xs :: [Int]) n -> compareLength xs n == compare (length xs) n" $ \(xs :: [Int]) n -> compareLength xs n == compare (length xs) n + testGen "compareLength (1:2:3:undefined) 2 == GT" $ compareLength (1:2:3:undefined) 2 == GT + testGen "comparingLength [1,2,3] [False] == GT" $ comparingLength [1,2,3] [False] == GT + testGen "comparingLength [1,2] \"ab\" == EQ" $ comparingLength [1,2] "ab" == EQ + testGen "\\(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys" $ \(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys + testGen "comparingLength [1,2] (1:2:3:undefined) == LT" $ comparingLength [1,2] (1:2:3:undefined) == LT + testGen "comparingLength (1:2:3:undefined) [1,2] == GT" $ comparingLength (1:2:3:undefined) [1,2] == GT testGen "(1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5]" $ (1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5] testGen "[1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5]" $ [1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5] testGen "appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5]" $ appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5] diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -14,7 +14,6 @@ import System.IO.Unsafe import Text.Show.Functions() -import Control.Applicative as X import Control.Concurrent.Extra as X import Control.Exception.Extra as X import Control.Monad.Extra as X