Hello community, here is the log from the commit of package ghc-extra for openSUSE:Factory checked in at 2018-05-30 12:07:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-extra (Old) and /work/SRC/openSUSE:Factory/.ghc-extra.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-extra" Wed May 30 12:07:13 2018 rev:16 rq:607794 version:1.6.6 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-extra/ghc-extra.changes 2017-09-15 21:39:01.577458333 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-extra.new/ghc-extra.changes 2018-05-30 12:25:37.937684616 +0200 @@ -1,0 +2,17 @@ +Mon May 14 17:02:11 UTC 2018 - [email protected] + +- Update extra to version 1.6.6. + * Add escapeJSON and unescapeJSON + * Add escapeHTML and unescapeHTML + * #33, improve error messages on test suite failures + * Add dropPrefix and dropSuffix + * Add maximumOn and minimumOn + * #31, add nubSort, nubSortBy and nubSortOn + * Mark the partial functions with Partial + * Add Partial constraint + * Add newTempFileWithin and newTempDirWithin + * Mark the Extra module as deprecated, used for documentation only + * #23, delete subtractTime + * Require QuickCheck-2.10 + +------------------------------------------------------------------- Old: ---- extra-1.5.3.tar.gz New: ---- extra-1.6.6.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-extra.spec ++++++ --- /var/tmp/diff_new_pack.SzQvaD/_old 2018-05-30 12:25:38.653660935 +0200 +++ /var/tmp/diff_new_pack.SzQvaD/_new 2018-05-30 12:25:38.657660803 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-extra # -# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name extra %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.5.3 +Version: 1.6.6 Release: 0 Summary: Extra functions I use License: BSD-3-Clause @@ -79,7 +79,7 @@ %ghc_pkg_recache %files -f %{name}.files -%doc LICENSE +%license LICENSE %files devel -f %{name}-devel.files %doc CHANGES.txt README.md ++++++ extra-1.5.3.tar.gz -> extra-1.6.6.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/CHANGES.txt new/extra-1.6.6/CHANGES.txt --- old/extra-1.5.3/CHANGES.txt 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/CHANGES.txt 2018-04-16 22:51:31.000000000 +0200 @@ -1,92 +1,111 @@ Changelog for Extra -1.5.3 +1.6.6, released 2018-04-16 + Add escapeJSON and unescapeJSON + Add escapeHTML and unescapeHTML +1.6.5, released 2018-03-24 + #33, improve error messages on test suite failures +1.6.4, released 2018-02-23 + Add dropPrefix and dropSuffix +1.6.3, released 2018-01-26 + Add maximumOn and minimumOn + #31, add nubSort, nubSortBy and nubSortOn +1.6.2, released 2017-12-07 + Mark the partial functions with Partial + Add Partial constraint +1.6.1, released 2017-11-30 + Add newTempFileWithin and newTempDirWithin + Mark the Extra module as deprecated, used for documentation only +1.6, released 2017-06-16 + #23, delete subtractTime + Require QuickCheck-2.10 +1.5.3, released 2017-06-12 Add readMaybe, readEither -1.5.2 +1.5.2, released 2017-04-04 Add errorWithoutStackTrace to Control.Exception.Extra -1.5.1 +1.5.1, released 2016-10-25 #25, add zipFrom and zipWithFrom #24, add eitherToMaybe and maybeToEither Add fromLeft' and fromRight' -1.5 +1.5, released 2016-07-21 Change fromLeft/fromRight signatures to follow the base libraries -1.4.12 +1.4.12, released 2016-07-18 Add writeVar -1.4.11 +1.4.11, released 2016-07-15 Require QuickCheck 2.9 #23, deprecate offsetTimeIncrease and subtract #22, improve offsetTime to give reliable measurements Depend on the clock library -1.4.10 +1.4.10, released 2016-06-15 Add Data.Typeable.Extra containing typeRep, Proxy, (:~:) -1.4.9 +1.4.9, released 2016-06-01 Add line1 -1.4.8 +1.4.8, released 2016-05-26 Add displayException -1.4.7 +1.4.7, released 2016-05-22 #21, add concatForM -1.4.6 +1.4.6, released 2016-05-11 #11, add maybeM and eitherM -1.4.5 +1.4.5, released 2016-04-29 #17, change fileEq on files that do not exist to be an error -1.4.4 +1.4.4, released 2016-04-29 #14, add mconcatMap and mconcatMapM #16, add fileEq #15, add isMac -1.4.3 +1.4.3, released 2016-01-07 Add Data.Version.Extra -1.4.2 +1.4.2, released 2015-09-14 Make concatMapM/mapMaybeM faster -1.4.1 +1.4.1, released 2015-08-04 Make temp file functions workaround GHC bug #10731 Add retryBool -1.4 +1.4, released 2015-07-23 Add stripInfix and stripInfixEnd -1.3.1 +1.3.1, released 2015-07-17 #9, support directory-1.2.3 -1.3 +1.3, released 2015-06-20 Add whenJustM Add errorIO -1.2 +1.2, released 2015-05-18 Add onceFork Make once async exception safe Fix a deadlock in once when two people request in parallel Fix a missing hClose in captureOutput -1.1 +1.1, released 2015-02-17 #7, add nubOrd, nubOrdOn, nubOrdBy #6, add groupSortOn and groupSortBy #5, add splitAtEnd -1.0.1 +1.0.1, released 2015-01-09 Make listFilesAvoid drop trailing path separators before testing #3, add a constraint base >= 4.4 -1.0 +1.0, released 2014-11-27 No changes -0.8 +0.8, released 2014-11-12 Fix a bug in writeFileEncoding/writeFileUTF8 -0.7 +0.7, released 2014-11-03 Fix for missing case in withNumCapabilities -0.6 +0.6, released 2014-10-31 Ensure barrier is thread-safe Make subsequent signalBarrier calls throw an exception Add timeout function Make sure sleep never wraps round an Int -0.5.1 +0.5.1, released 2014-10-28 Use uncons from GHC 7.9 and above -0.5 +0.5, released 2014-10-28 Use the sortOn from GHC 7.9 and above Remove getProcessorCount Remove getDirectoryContentsRecursive in favour of listFilesRecursive Change the signature for newTempFile/newTempDir Add a once function -0.4 +0.4, released 2014-10-23 Remove all but the extractors on triples Remove groupSortOn Remove dropAround -0.3.2 +0.3.2, released 2014-10-21 Remove use of ===, allows older QuickCheck versions -0.3.1 +0.3.1, released 2014-10-20 Fix a bug in breakEnd/spanEnd -0.3 +0.3, released 2014-10-18 Rename showTime to showDuration Add stringException Eliminate rep/reps, use replace instead @@ -99,11 +118,11 @@ Add createDirectoryPrivate Rename strip* to trim* Generalise showException -0.2 +0.2, released 2014-10-07 Redo the cons/uncons functions Add withTempDir Rename withTemporaryFile to withTempFile Change trim to strip (follow text naming convention) Ensure operators get exported -0.1 +0.1, released 2014-10-06 Initial version, still unstable diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/Generate.hs new/extra-1.6.6/Generate.hs --- old/extra-1.5.3/Generate.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/Generate.hs 2018-04-16 22:51:31.000000000 +0200 @@ -5,6 +5,7 @@ import Data.List.Extra import System.IO.Extra +import Control.Exception import Control.Monad.Extra import System.FilePath import System.Directory @@ -33,7 +34,7 @@ ,"--" ,"-- Most users should import the specific modules (e.g. @\"Data.List.Extra\"@), which" ,"-- also reexport their non-@Extra@ modules (e.g. @\"Data.List\"@)." - ,"module Extra("] ++ + ,"module Extra {-# DEPRECATED \"This module is provided as documentation of all new functions, you should import the more specific modules directly.\" #-} ("] ++ concat [ [" -- * " ++ mod ," -- | Extra functions available in @" ++ show mod ++ "@." ," " ++ unwords (map (++",") funs)] @@ -60,6 +61,7 @@ writeFileBinaryChanged :: FilePath -> String -> IO () writeFileBinaryChanged file x = do + evaluate $ length x -- ensure we don't write out files with _|_ in them old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (return Nothing) when (Just x /= old) $ writeFileBinary file x diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/LICENSE new/extra-1.6.6/LICENSE --- old/extra-1.5.3/LICENSE 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/LICENSE 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2014-2017. +Copyright Neil Mitchell 2014-2018. All rights reserved. Redistribution and use in source and binary forms, with or without diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/README.md new/extra-1.6.6/README.md --- old/extra-1.5.3/README.md 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/README.md 2018-04-16 22:51:31.000000000 +0200 @@ -9,7 +9,6 @@ The module `Extra` documents all functions provided by this library. Modules such as `Data.List.Extra` provide extra functions over `Data.List` and also reexport `Data.List`. Users are recommended to replace `Data.List` imports with `Data.List.Extra` if they need the extra functionality. - ## Which functions? When producing a library of extra functions I have been guided by a few principles. I encourage others with small useful utility functions contribute them here, perhaps as a temporary stop before proposing they join the standard libraries. @@ -19,16 +18,6 @@ * Most of the functions have trivial implementations. If a beginner couldn't write the function, it probably doesn't belong here. * I have defined only a few new data types or type aliases. It's a package for defining new utilities on existing types, not new types or concepts. - ## Base versions -The following GHC versions correspond to the following base library versions: - -* base 4.9 == GHC 8.0 -* base 4.8 == GHC 7.10 -* base 4.7 == GHC 7.8 -* base 4.6 == GHC 7.6 -* base 4.5 == GHC 7.4 -* base 4.4 == GHC 7.2 - -A more complete list can be found [here](https://wiki.haskell.org/Base_package#Versions). +A mapping between `base` versions and GHC compiler versions can be found [here](https://wiki.haskell.org/Base_package#Versions). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/extra.cabal new/extra-1.6.6/extra.cabal --- old/extra-1.5.3/extra.cabal 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/extra.cabal 2018-04-16 22:51:31.000000000 +0200 @@ -1,13 +1,13 @@ cabal-version: >= 1.18 build-type: Simple name: extra -version: 1.5.3 +version: 1.6.6 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <[email protected]> maintainer: Neil Mitchell <[email protected]> -copyright: Neil Mitchell 2014-2017 +copyright: Neil Mitchell 2014-2018 synopsis: Extra functions I use. description: 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.2. @@ -15,7 +15,7 @@ The module "Extra" documents all functions provided by this library. Modules such as "Data.List.Extra" provide extra functions over "Data.List" and also reexport "Data.List". Users are recommended to replace "Data.List" imports with "Data.List.Extra" if they need the extra functionality. homepage: https://github.com/ndmitchell/extra#readme bug-reports: https://github.com/ndmitchell/extra/issues -tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-doc-files: CHANGES.txt @@ -40,6 +40,8 @@ if !os(windows) build-depends: unix + other-modules: + Partial exposed-modules: Extra Control.Concurrent.Extra @@ -68,9 +70,7 @@ directory, filepath, extra, - clock >= 0.7, - time, - QuickCheck >= 2.9 + QuickCheck >= 2.10 if !os(windows) build-depends: unix hs-source-dirs: test diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Control/Concurrent/Extra.hs new/extra-1.6.6/src/Control/Concurrent/Extra.hs --- old/extra-1.5.3/src/Control/Concurrent/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Control/Concurrent/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE CPP, TupleSections, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | Extra functions for "Control.Concurrent". @@ -226,7 +226,7 @@ -- | Write a value into the Barrier, releasing anyone at 'waitBarrier'. -- Any subsequent attempts to signal the 'Barrier' will throw an exception. -signalBarrier :: Barrier a -> a -> IO () +signalBarrier :: Partial => Barrier a -> a -> IO () signalBarrier (Barrier var) v = mask_ $ -- use mask so never in an inconsistent state join $ modifyVar var $ \x -> case x of Left bar -> return (Right v, putMVar bar ()) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Control/Exception/Extra.hs new/extra-1.6.6/src/Control/Exception/Extra.hs --- old/extra-1.5.3/src/Control/Exception/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Control/Exception/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE ScopedTypeVariables, CPP, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | Extra functions for "Control.Exception". @@ -6,6 +6,7 @@ -- and functions to catch\/ignore exceptions, including monomorphic (no 'Exception' context) versions. module Control.Exception.Extra( module Control.Exception, + Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, @@ -21,6 +22,7 @@ import Control.Monad import Data.List.Extra import Data.Functor +import Partial import Prelude @@ -73,7 +75,7 @@ -- Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception. -- -- > try (errorIO "Hello") == return (Left (ErrorCall "Hello")) -errorIO :: String -> IO a +errorIO :: Partial => String -> IO a errorIO = throwIO . ErrorCall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Data/Either/Extra.hs new/extra-1.6.6/src/Data/Either/Extra.hs --- old/extra-1.5.3/src/Data/Either/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Data/Either/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.Either" with extra operations, particularly @@ -12,6 +12,7 @@ ) where import Data.Either +import Partial #if __GLASGOW_HASKELL__ < 801 @@ -41,7 +42,7 @@ -- -- > \x -> fromLeft' (Left x) == x -- > \x -> fromLeft' (Right x) == undefined -fromLeft' :: Either l r -> l +fromLeft' :: Partial => Either l r -> l fromLeft' (Left x) = x fromLeft' _ = error "fromLeft', given a Right" @@ -51,7 +52,7 @@ -- -- > \x -> fromRight' (Right x) == x -- > \x -> fromRight' (Left x) == undefined -fromRight' :: Either l r -> r +fromRight' :: Partial => Either l r -> r fromRight' (Right x) = x fromRight' _ = error "fromRight', given a Left" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Data/List/Extra.hs new/extra-1.6.6/src/Data/List/Extra.hs --- old/extra-1.5.3/src/Data/List/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Data/List/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns #-} +{-# LANGUAGE CPP, TupleSections, BangPatterns, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.List" with extra functions of a similar nature. @@ -9,10 +9,13 @@ module Data.List, -- * String operations lower, upper, trim, trimStart, trimEnd, word1, line1, - -- * Splitting + escapeHTML, escapeJSON, + unescapeHTML, unescapeJSON, + -- * Splitting dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, + dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, -- * Basics @@ -21,6 +24,8 @@ groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, + nubSort, nubSortBy, nubSortOn, + maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, @@ -28,12 +33,14 @@ replace, merge, mergeBy, ) where +import Partial import Data.List import Data.Maybe import Data.Function import Data.Char import Data.Tuple.Extra import Data.Monoid +import Numeric import Data.Functor import Prelude @@ -179,13 +186,14 @@ -- -- > \i xs -> zip [i..] xs == zipFrom i xs -- > zipFrom False [1..3] == undefined -zipFrom :: Enum a => a -> [b] -> [(a, b)] +zipFrom :: (Partial, Enum a) => a -> [b] -> [(a, b)] zipFrom = zipWithFrom (,) -- | 'zipFrom' generalised to any combining operation. +-- Never truncates the output - raises an error if the enumeration runs out. -- -- > \i xs -> zipWithFrom (,) i xs == zipFrom i xs -zipWithFrom :: Enum a => (a -> b -> c) -> a -> [b] -> [c] +zipWithFrom :: (Partial, Enum a) => (a -> b -> c) -> a -> [b] -> [c] zipWithFrom f a xs = go a xs where -- if we aren't strict in the accumulator, it's highly like to be a space leak @@ -267,6 +275,73 @@ line1 :: String -> (String, String) line1 = second drop1 . break (== '\n') +-- | Escape a string such that it can be inserted into an HTML document or @\"@ attribute +-- without any special interpretation. This requires escaping the @<@, @>@, @&@ and @\"@ characters. +-- Note that it does /not/ escape @\'@, so will not work when placed in a @\'@ delimited attribute. +-- Also note that it will escape @\"@ even though that is not required in an HTML body (but is not harmful). +-- +-- > escapeHTML "this is a test" == "this is a test" +-- > escapeHTML "<b>\"g&t\"</n>" == "<b>"g&t"</n>" +-- > escapeHTML "don't" == "don't" +escapeHTML :: String -> String +escapeHTML = concatMap f + where + f '>' = ">" + f '<' = "<" + f '&' = "&" + f '\"' = """ + f x = [x] + +-- | Invert of 'escapeHTML' (does not do general HTML unescaping) +-- +-- > \xs -> unescapeHTML (escapeHTML xs) == xs +unescapeHTML :: String -> String +unescapeHTML ('&':xs) + | Just xs <- stripPrefix "lt;" xs = '<' : unescapeHTML xs + | Just xs <- stripPrefix "gt;" xs = '>' : unescapeHTML xs + | Just xs <- stripPrefix "amp;" xs = '&' : unescapeHTML xs + | Just xs <- stripPrefix "quot;" xs = '\"' : unescapeHTML xs +unescapeHTML (x:xs) = x : unescapeHTML xs +unescapeHTML [] = [] + + +-- | Escape a string so it can form part of a JSON literal. +-- This requires escaping the special whitespace and control characters. Additionally, +-- Note that it does /not/ add quote characters around the string. +-- +-- > escapeJSON "this is a test" == "this is a test" +-- > escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" +-- > escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" +escapeJSON :: String -> String +escapeJSON x = concatMap f x + where f '\"' = "\\\"" + f '\\' = "\\\\" + -- the spaces are technically optional, but we include them so the JSON is readable + f '\b' = "\\b" + f '\f' = "\\f" + f '\n' = "\\n" + f '\r' = "\\r" + f '\t' = "\\t" + f x | isControl x = "\\u" ++ takeEnd 4 ("0000" ++ showHex (ord x) "") + f x = [x] + +-- | General JSON unescaping, inversion of 'escapeJSON' and all other JSON escapes. +-- +-- > \xs -> unescapeJSON (escapeJSON xs) == xs +unescapeJSON :: String -> String +unescapeJSON ('\\':x:xs) + | x == '\"' = '\"' : unescapeJSON xs + | x == '\\' = '\\' : unescapeJSON xs + | x == '/' = '/' : unescapeJSON xs + | x == 'b' = '\b' : unescapeJSON xs + | x == 'f' = '\f' : unescapeJSON xs + | x == 'n' = '\n' : unescapeJSON xs + | x == 'r' = '\r' : unescapeJSON xs + | x == 't' = '\t' : unescapeJSON xs + | x == 'u', let (a,b) = splitAt 4 xs, length a == 4, [(i, "")] <- readHex a = chr i : unescapeJSON b +unescapeJSON (x:xs) = x : unescapeJSON xs +unescapeJSON [] = [] + #if __GLASGOW_HASKELL__ < 709 -- | Sort a list by comparing the results of a key function applied to each @@ -294,6 +369,13 @@ nubOn :: Eq b => (a -> b) -> [a] -> [a] nubOn f = map snd . nubBy ((==) `on` fst) . map (\x -> let y = f x in y `seq` (y, x)) +-- | A version of 'maximum' where the comparison is done on some extracted value. +maximumOn :: Ord b => (a -> b) -> [a] -> a +maximumOn f = maximumBy (compare `on` f) + +-- | A version of 'minimum' where the comparison is done on some extracted value. +minimumOn :: Ord b => (a -> b) -> [a] -> a +minimumOn f = minimumBy (compare `on` f) -- | A combination of 'group' and 'sort'. -- @@ -340,7 +422,7 @@ -- > replace "el" "e" "Hello" == "Helo" -- > replace "" "e" "Hello" == undefined -- > \xs ys -> not (null xs) ==> replace xs xs ys == ys -replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace :: (Partial, Eq a) => [a] -> [a] -> [a] -> [a] replace [] _ _ = error "Extra.replace, first argument cannot be empty" replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs replace from to (x:xs) = x : replace from to xs @@ -425,7 +507,7 @@ -- The first element of the returned tuple -- is the prefix of @haystack@ before @needle@ is matched. The second -- is the remainder of @haystack@, starting with the match. --- If you want the remainder /without/ the patch, use 'stripInfix'. +-- If you want the remainder /without/ the match, use 'stripInfix'. -- -- > breakOn "::" "a::b::c" == ("a", "::b::c") -- > breakOn "/" "foobar" == ("foobar", "") @@ -457,7 +539,7 @@ -- > splitOn "x" "" == [""] -- > \s x -> s /= "" ==> intercalate s (splitOn s x) == x -- > \c x -> splitOn [c] x == split (==c) x -splitOn :: Eq a => [a] -> [a] -> [[a]] +splitOn :: (Partial, Eq a) => [a] -> [a] -> [[a]] splitOn [] _ = error "splitOn, needle may not be empty" splitOn _ [] = [[]] splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b @@ -501,8 +583,27 @@ dropWhileEnd' :: (a -> Bool) -> [a] -> [a] dropWhileEnd' p = foldr (\x xs -> if null xs && p x then [] else x : xs) [] --- | Return the prefix of the second string if its suffix --- matches the entire first string. + +-- | Drops the given prefix from a list. +-- It returns the original sequence if the sequence doesn't start with the given prefix. +-- +-- > dropPrefix "Mr. " "Mr. Men" == "Men" +-- > dropPrefix "Mr. " "Dr. Men" == "Dr. Men" +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix a b = fromMaybe b $ stripPrefix a b + + +-- | Drops the given suffix from a list. +-- It returns the original sequence if the sequence doesn't end with the given suffix. +-- +-- > dropSuffix "!" "Hello World!" == "Hello World" +-- > dropSuffix "!" "Hello World!!" == "Hello World!" +-- > dropSuffix "!" "Hello World." == "Hello World." +dropSuffix :: Eq a => [a] -> [a] -> [a] +dropSuffix a b = fromMaybe b $ stripSuffix a b + +-- | Return the prefix of the second list if its suffix +-- matches the entire first list. -- -- Examples: -- @@ -541,11 +642,34 @@ -- > chunksOf 3 "mytest" == ["myt","est"] -- > chunksOf 8 "" == [] -- > chunksOf 0 "test" == undefined -chunksOf :: Int -> [a] -> [[a]] +chunksOf :: Partial => Int -> [a] -> [[a]] chunksOf i xs | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i chunksOf i xs = repeatedly (splitAt i) xs +-- | /O(n log n)/. The 'nubSort' function sorts and removes duplicate elements from a list. +-- In particular, it keeps only the first occurrence of each element. +-- +-- > nubSort "this is a test" == " aehist" +-- > \xs -> nubSort xs == nub (sort xs) +nubSort :: Ord a => [a] -> [a] +nubSort = nubSortBy compare + +-- | A version of 'nubSort' which operates on a portion of the value. +-- +-- > nubSortOn length ["a","test","of","this"] == ["a","of","test"] +nubSortOn :: Ord b => (a -> b) -> [a] -> [a] +nubSortOn f = nubSortBy (compare `on` f) + +-- | A version of 'nubSort' with a custom predicate. +-- +-- > nubSortBy (compare `on` length) ["a","test","of","this"] == ["a","of","test"] +nubSortBy :: (a -> a -> Ordering) -> [a] -> [a] +nubSortBy cmp = f . sortBy cmp + where f (x1:x2:xs) | cmp x1 x2 == EQ = f (x1:xs) + f (x:xs) = x : f xs + f [] = [] + -- | /O(n log n)/. The 'nubOrd' function removes duplicate elements from a list. -- In particular, it keeps only the first occurrence of each element. -- Unlike the standard 'nub' operator, this version requires an 'Ord' instance diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Data/Version/Extra.hs new/extra-1.6.6/src/Data/Version/Extra.hs --- old/extra-1.5.3/src/Data/Version/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Data/Version/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.Version" with extra utilities. @@ -8,6 +8,7 @@ makeVersion, readVersion ) where +import Partial import Data.Version import Data.List.Extra import Text.ParserCombinators.ReadP @@ -27,7 +28,7 @@ -- -- > \x -> readVersion (showVersion x) == x -- > readVersion "hello" == undefined -readVersion :: String -> Version +readVersion :: Partial => String -> Version readVersion s = case [ x | (x,"") <- readP_to_S parseVersion $ trimEnd s] of [x] -> x diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Extra.hs new/extra-1.6.6/src/Extra.hs --- old/extra-1.5.3/src/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -5,13 +5,13 @@ -- -- Most users should import the specific modules (e.g. @"Data.List.Extra"@), which -- also reexport their non-@Extra@ modules (e.g. @"Data.List"@). -module Extra( +module Extra {-# DEPRECATED "This module is provided as documentation of all new functions, you should import the more specific modules directly." #-} ( -- * Control.Concurrent.Extra -- | Extra functions available in @"Control.Concurrent.Extra"@. getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, writeVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, -- * Control.Exception.Extra -- | Extra functions available in @"Control.Exception.Extra"@. - retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, displayException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, + Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, displayException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. whenJust, whenJustM, unit, maybeM, eitherM, loopM, whileM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, @@ -23,7 +23,7 @@ modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef', -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. - lower, upper, trim, trimStart, trimEnd, word1, line1, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, + lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, -- * Data.Tuple.Extra -- | Extra functions available in @"Data.Tuple.Extra"@. first, second, (***), (&&&), dupe, both, fst3, snd3, thd3, @@ -47,13 +47,13 @@ isWindows, isMac, -- * System.IO.Extra -- | Extra functions available in @"System.IO.Extra"@. - captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, fileEq, + captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, newTempFileWithin, newTempDirWithin, fileEq, -- * System.Process.Extra -- | Extra functions available in @"System.Process.Extra"@. system_, systemOutput, systemOutput_, -- * System.Time.Extra -- | Extra functions available in @"System.Time.Extra"@. - Seconds, sleep, timeout, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration, + Seconds, sleep, timeout, showDuration, offsetTime, offsetTimeIncrease, duration, -- * Text.Read.Extra -- | Extra functions available in @"Text.Read.Extra"@. readEither, readMaybe, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/Partial.hs new/extra-1.6.6/src/Partial.hs --- old/extra-1.5.3/src/Partial.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/extra-1.6.6/src/Partial.hs 2018-04-16 22:51:31.000000000 +0200 @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP #-} + +-- | ConstraintKind synonym for marking partial functions +module Partial(Partial) where +-- Originally taken from the @safe@ package + +-- 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 + +-- We never support GHC 7.10.2 style because that requires users to pass the FlexibleContexts +-- extension + +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Stack +#else +import GHC.Exts +#endif + +-- | A constraint which documents that a function is partial, and on GHC 8.0 +-- and above produces a stack trace on failure. For example: +-- +-- @ +-- myHead :: 'Partial' => [a] -> a +-- myHead [] = error \"bad\" +-- myHead (x:xs) = x +-- @ +-- +-- When using 'Partial' with GHC 7.8 or below you need to enable the +-- language feature @ConstraintKinds@, e.g. @{-\# LANGUAGE ConstraintKinds \#-}@ +-- at the top of the file. +#if __GLASGOW_HASKELL__ >= 800 +type Partial = HasCallStack +#else +type Partial = (() :: Constraint) +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/System/IO/Extra.hs new/extra-1.6.6/src/System/IO/Extra.hs --- old/extra-1.5.3/src/System/IO/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/System/IO/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -16,6 +16,7 @@ writeFileEncoding, writeFileUTF8, writeFileBinary, -- * Temporary files withTempFile, withTempDir, newTempFile, newTempDir, + newTempFileWithin, newTempDirWithin, -- * File comparison fileEq, ) where @@ -103,7 +104,7 @@ -- | Write a binary file. -- --- > \s -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file +-- > \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file writeFileBinary :: FilePath -> String -> IO () writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x @@ -158,13 +159,16 @@ -- temporary file. Most users should use 'withTempFile' which -- combines these operations. newTempFile :: IO (FilePath, IO ()) -newTempFile = do +newTempFile = newTempFileWithin =<< getTemporaryDirectory + +-- | Like 'newTempFile' but using a custom temporary directory. +newTempFileWithin :: FilePath -> IO (FilePath, IO ()) +newTempFileWithin tmpdir = do file <- create del <- once $ ignore $ removeFile file return (file, del) where create = do - tmpdir <- getTemporaryDirectory val <- tempUnique (file, h) <- retryBool (\(_ :: IOError) -> True) 5 $ openTempFile tmpdir $ "extra-file-" ++ show val ++ "-" hClose h @@ -189,8 +193,11 @@ -- temporary directory. Most users should use 'withTempDir' which -- combines these operations. newTempDir :: IO (FilePath, IO ()) -newTempDir = do - tmpdir <- getTemporaryDirectory +newTempDir = newTempDirWithin =<< getTemporaryDirectory + +-- | Like 'newTempDir' but using a custom temporary directory. +newTempDirWithin :: FilePath -> IO (FilePath, IO ()) +newTempDirWithin tmpdir = do dir <- retryBool (\(_ :: IOError) -> True) 5 $ create tmpdir del <- once $ ignore $ removeDirectoryRecursive dir return (dir, del) @@ -221,7 +228,7 @@ foreign import ccall unsafe "string.h memcmp" memcmp :: Ptr CUChar -> Ptr CUChar -> CSize -> IO CInt --- | Returs 'True' when the contents of both files is the same. +-- | Returns 'True' when the contents of both files is the same. sameContent :: Handle -> Handle -> IO Bool sameContent h1 h2 = sameSize h1 h2 &&^ withb (\b1 -> withb $ \b2 -> eq b1 b2) where eq b1 b2 = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/System/Process/Extra.hs new/extra-1.6.6/src/System/Process/Extra.hs --- old/extra-1.5.3/src/System/Process/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/System/Process/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, ConstraintKinds #-} -- | Extra functions for creating processes. Specifically variants that automatically check -- the 'ExitCode' and capture the 'stdout'\/'stderr' handles. @@ -12,6 +12,7 @@ import System.Process import System.Exit import Data.Functor +import Partial import Prelude @@ -26,7 +27,7 @@ -- | A version of 'system' that throws an error if the 'ExitCode' is not 'ExitSuccess'. -system_ :: String -> IO () +system_ :: Partial => String -> IO () system_ x = do res <- system x when (res /= ExitSuccess) $ @@ -34,7 +35,7 @@ -- | A version of 'system' that captures the output (both 'stdout' and 'stderr') -- and throws an error if the 'ExitCode' is not 'ExitSuccess'. -systemOutput_ :: String -> IO String +systemOutput_ :: Partial => String -> IO String systemOutput_ x = do (res,out) <- systemOutput x when (res /= ExitSuccess) $ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/src/System/Time/Extra.hs new/extra-1.6.6/src/System/Time/Extra.hs --- old/extra-1.5.3/src/System/Time/Extra.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/src/System/Time/Extra.hs 2018-04-16 22:51:31.000000000 +0200 @@ -8,13 +8,11 @@ module System.Time.Extra( Seconds, sleep, timeout, - subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration ) where import Control.Concurrent -import Data.Time.Clock import System.Clock import Numeric.Extra import Control.Monad.Extra @@ -72,16 +70,6 @@ (\_ -> fmap Just f)) --- Once we remove subtractTime we can remove the dependency on the time package entire. -{-# DEPRECATED subtractTime "Function is being retired - use diffUTCTime directly." #-} - --- | Calculate the difference between two times in seconds. --- Usually the first time will be the end of an event, and the --- second time will be the beginning. -subtractTime :: UTCTime -> UTCTime -> Seconds -subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start - - -- | Show a number of seconds, typically a duration, in a suitable manner with -- responable precision for a human. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/test/TestCustom.hs new/extra-1.6.6/test/TestCustom.hs --- old/extra-1.5.3/test/TestCustom.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/test/TestCustom.hs 2018-04-16 22:51:31.000000000 +0200 @@ -6,8 +6,7 @@ import System.IO.Extra import Data.IORef import TestUtil - -import Extra as X +import Data.Typeable.Extra as X testCustom :: IO () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/test/TestGen.hs new/extra-1.6.6/test/TestGen.hs --- old/extra-1.5.3/test/TestGen.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/test/TestGen.hs 2018-04-16 22:51:31.000000000 +0200 @@ -132,6 +132,14 @@ testGen "line1 \"test\\n\" == (\"test\",\"\")" $ line1 "test\n" == ("test","") testGen "line1 \"test\\nrest\" == (\"test\",\"rest\")" $ line1 "test\nrest" == ("test","rest") testGen "line1 \"test\\nrest\\nmore\" == (\"test\",\"rest\\nmore\")" $ line1 "test\nrest\nmore" == ("test","rest\nmore") + testGen "escapeHTML \"this is a test\" == \"this is a test\"" $ escapeHTML "this is a test" == "this is a test" + testGen "escapeHTML \"<b>\\\"g&t\\\"</n>\" == \"<b>"g&t"</n>\"" $ escapeHTML "<b>\"g&t\"</n>" == "<b>"g&t"</n>" + testGen "escapeHTML \"don't\" == \"don't\"" $ escapeHTML "don't" == "don't" + testGen "\\xs -> unescapeHTML (escapeHTML xs) == xs" $ \xs -> unescapeHTML (escapeHTML xs) == xs + testGen "escapeJSON \"this is a test\" == \"this is a test\"" $ escapeJSON "this is a test" == "this is a test" + testGen "escapeJSON \"\\ttab\\nnewline\\\\\" == \"\\\\ttab\\\\nnewline\\\\\\\\\"" $ escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" + testGen "escapeJSON \"\\ESC[0mHello\" == \"\\\\u001b[0mHello\"" $ escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" + testGen "\\xs -> unescapeJSON (escapeJSON xs) == xs" $ \xs -> unescapeJSON (escapeJSON xs) == xs testGen "sortOn fst [(3,\"z\"),(1,\"\"),(3,\"a\")] == [(1,\"\"),(3,\"z\"),(3,\"a\")]" $ sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] testGen "groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,\"t\"),(2,\"es\"),(3,\"t\")]" $ groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,"t"),(2,"es"),(3,"t")] testGen "\\xs -> map fst (groupSort xs) == sort (nub (map fst xs))" $ \xs -> map fst (groupSort xs) == sort (nub (map fst xs)) @@ -184,6 +192,11 @@ testGen "last (dropWhileEnd' even [undefined,3]) == 3" $ last (dropWhileEnd' even [undefined,3]) == 3 testGen "head (dropWhileEnd even (3:undefined)) == 3" $ head (dropWhileEnd even (3:undefined)) == 3 testGen "head (dropWhileEnd' even (3:undefined)) == undefined" $ erroneous $ head (dropWhileEnd' even (3:undefined)) + testGen "dropPrefix \"Mr. \" \"Mr. Men\" == \"Men\"" $ dropPrefix "Mr. " "Mr. Men" == "Men" + testGen "dropPrefix \"Mr. \" \"Dr. Men\" == \"Dr. Men\"" $ dropPrefix "Mr. " "Dr. Men" == "Dr. Men" + testGen "dropSuffix \"!\" \"Hello World!\" == \"Hello World\"" $ dropSuffix "!" "Hello World!" == "Hello World" + testGen "dropSuffix \"!\" \"Hello World!!\" == \"Hello World!\"" $ dropSuffix "!" "Hello World!!" == "Hello World!" + testGen "dropSuffix \"!\" \"Hello World.\" == \"Hello World.\"" $ dropSuffix "!" "Hello World." == "Hello World." testGen "stripSuffix \"bar\" \"foobar\" == Just \"foo\"" $ stripSuffix "bar" "foobar" == Just "foo" testGen "stripSuffix \"\" \"baz\" == Just \"baz\"" $ stripSuffix "" "baz" == Just "baz" testGen "stripSuffix \"foo\" \"quux\" == Nothing" $ stripSuffix "foo" "quux" == Nothing @@ -194,6 +207,10 @@ testGen "chunksOf 3 \"mytest\" == [\"myt\",\"est\"]" $ chunksOf 3 "mytest" == ["myt","est"] testGen "chunksOf 8 \"\" == []" $ chunksOf 8 "" == [] testGen "chunksOf 0 \"test\" == undefined" $ erroneous $ chunksOf 0 "test" + testGen "nubSort \"this is a test\" == \" aehist\"" $ nubSort "this is a test" == " aehist" + testGen "\\xs -> nubSort xs == nub (sort xs)" $ \xs -> nubSort xs == nub (sort xs) + testGen "nubSortOn length [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"of\",\"test\"]" $ nubSortOn length ["a","test","of","this"] == ["a","of","test"] + testGen "nubSortBy (compare `on` length) [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"of\",\"test\"]" $ nubSortBy (compare `on` length) ["a","test","of","this"] == ["a","of","test"] testGen "nubOrd \"this is a test\" == \"this ae\"" $ nubOrd "this is a test" == "this ae" testGen "nubOrd (take 4 (\"this\" ++ undefined)) == \"this\"" $ nubOrd (take 4 ("this" ++ undefined)) == "this" testGen "\\xs -> nubOrd xs == nub xs" $ \xs -> nubOrd xs == nub xs @@ -224,7 +241,7 @@ testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32") testGen "\\(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \\file -> do writeFile file s; readFile' file" $ \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file testGen "\\s -> withTempFile $ \\file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file" $ \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file - testGen "\\s -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \s -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file + testGen "\\(ASCIIString s) -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file testGen "captureOutput (print 1) == return (\"1\\n\",())" $ captureOutput (print 1) == return ("1\n",()) testGen "withTempFile doesFileExist == return True" $ withTempFile doesFileExist == return True testGen "(doesFileExist =<< withTempFile return) == return False" $ (doesFileExist =<< withTempFile return) == return False diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.5.3/test/TestUtil.hs new/extra-1.6.6/test/TestUtil.hs --- old/extra-1.5.3/test/TestUtil.hs 2017-06-12 23:58:38.000000000 +0200 +++ new/extra-1.6.6/test/TestUtil.hs 2018-04-16 22:51:31.000000000 +0200 @@ -1,34 +1,40 @@ {-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- OK because a test module -module TestUtil(runTests, testGen, testRaw, erroneous, erroneousIO, (====), module X) where +module TestUtil + (runTests + ,testGen, testRaw + ,erroneous, erroneousIO + ,(====), (==>) + ,ASCIIString(..) + ,module X + ) where import Test.QuickCheck import Test.QuickCheck.Test -import Control.Exception.Extra -import Data.Either.Extra -import System.IO.Extra -import Data.Version.Extra -import Data.IORef import System.IO.Unsafe -import Data.Time.Clock -import Data.Time.Calendar import Text.Show.Functions() -import Extra as X import Control.Applicative as X -import Control.Monad as X -import Data.Function as X -import Data.List as X +import Control.Concurrent.Extra as X +import Control.Exception.Extra as X +import Control.Monad.Extra as X import Data.Char as X +import Data.Either.Extra as X +import Data.Function as X +import Data.IORef.Extra as X +import Data.List.Extra as X import Data.Monoid as X -import Data.Tuple as X -import Data.Typeable as X -import Data.Version as X -import System.Directory as X +import Data.Tuple.Extra as X +import Data.Typeable.Extra as X +import Data.Version.Extra as X +import Numeric.Extra as X +import System.Directory.Extra as X import System.FilePath as X -import System.Info as X -import Control.Exception as X -import Test.QuickCheck as X((==>)) +import System.Info.Extra as X +import System.IO.Extra as X +import System.Process.Extra as X +import System.Time.Extra as X {-# NOINLINE testCount #-} @@ -65,22 +71,26 @@ runTests :: IO () -> IO () runTests t = do + -- ensure that capturing output is robust + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering writeIORef testCount 0 t n <- readIORef testCount putStrLn $ "Success (" ++ show n ++ " tests)" -instance Testable () where - property = property . (`seq` True) - instance Testable a => Testable (IO a) where property = property . unsafePerformIO -instance Eq a => Eq (IO a) where +-- We only use this property to assert equality as a property +-- And the Show instance is useless (since it may be non-deterministic) +-- So we print out full information on failure +instance (Show a, Eq a) => Eq (IO a) where a == b = unsafePerformIO $ do a <- try_ $ captureOutput a b <- try_ $ captureOutput b - return $ a == b + if a == b then return True else + error $ show ("IO values not equal", a, b) instance Show (IO a) where show _ = "<<IO>>" @@ -95,12 +105,3 @@ instance Eq SomeException where a == b = show a == show b - -instance Arbitrary UTCTime where - arbitrary = liftM2 UTCTime arbitrary arbitrary - -instance Arbitrary Day where - arbitrary = fmap ModifiedJulianDay arbitrary - -instance Arbitrary DiffTime where - arbitrary = realToFrac <$> choose (0 :: Double, 86401)
