diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,98 +1,101 @@ Changelog for Extra -1.6.1 +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 +1.6, released 2017-06-16 #23, delete subtractTime Require QuickCheck-2.10 -1.5.3 +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 @@ -105,11 +108,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 --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.6.1 +version: 1.6.2 license: BSD3 license-file: LICENSE category: Development @@ -40,6 +40,8 @@ if !os(windows) build-depends: unix + other-modules: + Partial exposed-modules: Extra Control.Concurrent.Extra @@ -68,7 +70,6 @@ directory, filepath, extra, - clock >= 0.7, QuickCheck >= 2.10 if !os(windows) build-depends: unix 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 @@ -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 --git a/src/Control/Exception/Extra.hs b/src/Control/Exception/Extra.hs --- a/src/Control/Exception/Extra.hs +++ b/src/Control/Exception/Extra.hs @@ -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 --git a/src/Data/Either/Extra.hs b/src/Data/Either/Extra.hs --- a/src/Data/Either/Extra.hs +++ b/src/Data/Either/Extra.hs @@ -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 --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 @@ -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. @@ -28,6 +28,7 @@ replace, merge, mergeBy, ) where +import Partial import Data.List import Data.Maybe import Data.Function @@ -179,13 +180,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 @@ -340,7 +342,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 @@ -457,7 +459,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 @@ -541,7 +543,7 @@ -- > 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 diff --git a/src/Data/Version/Extra.hs b/src/Data/Version/Extra.hs --- a/src/Data/Version/Extra.hs +++ b/src/Data/Version/Extra.hs @@ -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 --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -11,7 +11,7 @@ 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, diff --git a/src/Partial.hs b/src/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Partial.hs @@ -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 --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs --- a/src/System/Process/Extra.hs +++ b/src/System/Process/Extra.hs @@ -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) $