diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,7 @@ Changelog for Extra +0.3.2 + Remove use of ===, allows older QuickCheck versions 0.3.1 Fix a bug in breakEnd/spanEnd 0.3 diff --git a/Generate.hs b/Generate.hs new file mode 100644 --- /dev/null +++ b/Generate.hs @@ -0,0 +1,68 @@ + +module Generate(main) where + +import Data.List.Extra +import System.IO.Extra +import Control.Monad.Extra +import Control.Applicative +import System.FilePath +import System.Directory +import Data.Char +import Data.Maybe + + +main :: IO () +main = do + src <- readFile "extra.cabal" + mods <- return $ filter (isSuffixOf ".Extra") $ map trim $ lines src + ifaces <- forM mods $ \mod -> do + src <- readFile $ joinPath ("src" : split (== '.') mod) <.> "hs" + let funcs = filter validIdentifier $ takeWhile (/= "where") $ + words $ replace "," " " $ drop1 $ dropWhile (/= '(') $ + unlines $ filter (not . isPrefixOf "--" . trim) $ lines src + let tests = mapMaybe (stripPrefix "-- > ") $ lines src + return (mod, funcs, tests) + writeFileBinaryChanged "src/Extra.hs" $ unlines $ + ["-- | This module documents all the functions available in this package." + ,"--" + ,"-- 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("] ++ + concat [ [" -- * " ++ mod + ," -- | Extra functions available in @" ++ show mod ++ "@." + ," " ++ unwords (map (++",") funs)] + | (mod,funs,_) <- ifaces] ++ + [" ) where" + ,""] ++ + ["import " ++ x | x <- mods] + writeFileBinaryChanged "test/TestGen.hs" $ unlines $ + ["{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables #-}" + ,"module TestGen(tests) where" + ,"import TestUtil" + ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))" + ,"tests :: IO ()" + ,"tests = do"] ++ + [" testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- ts] + +writeFileBinaryChanged :: FilePath -> String -> IO () +writeFileBinaryChanged file x = do + old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (return Nothing) + when (Just x /= old) $ + writeFileBinary file x + + +validIdentifier xs = + (take 1 xs == "(" || isName xs) && + xs `notElem` ["module","Numeric"] + +isName (x:xs) = isAlpha x && all (\x -> isAlphaNum x || x `elem` "_'") xs +isName _ = False + +tweakTest x + | Just x <- stripSuffix " == undefined" x = + if not $ "\\" `isPrefixOf` x then + "erroneous $ " ++ x + else + let (a,b) = breakOn "->" x + in a ++ "-> erroneous $ " ++ drop 2 b + | otherwise = x diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: extra -version: 0.3.1 +version: 0.3.2 license: BSD3 license-file: LICENSE category: Development @@ -20,6 +20,7 @@ extra-source-files: CHANGES.txt README.md + Generate.hs source-repository head type: git 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 @@ -158,7 +158,7 @@ -- @ -- bar <- 'newBarrier' -- forkIO $ do ...; val <- ...; 'signalBarrier' bar val --- print =<< waitBarrier bar +-- print =<< 'waitBarrier' bar -- @ -- -- Here we create a barrier which will contain some computed value. 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 @@ -67,7 +67,14 @@ Left x -> loopM act x Right v -> return v --- | Keep running an operation until it becomes 'False'. +-- | Keep running an operation until it becomes 'False'. As an example: +-- +-- @ +-- whileM $ do sleep 0.1; notM $ doesFileExist "foo.txt" +-- readFile "foo.txt" +-- @ +-- +-- If you need some state persisted between each test, use 'loopM'. whileM :: Monad m => m Bool -> m () whileM act = do b <- act @@ -75,44 +82,88 @@ -- Booleans +-- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () whenM b t = ifM b t (return ()) +-- | Like 'unless', but where the test can be monadic. unlessM :: Monad m => m Bool -> m () -> m () unlessM b f = ifM b (return ()) f +-- | Like @if@, but where the test can be monadic. ifM :: Monad m => m Bool -> m a -> m a -> m a ifM b t f = do b <- b; if b then t else f +-- | Like 'not', but where the test can be monadic. notM :: Functor m => m Bool -> m Bool notM = fmap not --- > Just False &&^ undefined == Just False --- > Just True &&^ Just True == Just True -(||^), (&&^) :: Monad m => m Bool -> m Bool -> m Bool +-- | The lazy '||' operator lifted to a monad. If the first +-- argument evaluates to 'True' the second argument will not +-- be evaluated. +-- +-- > Just True ||^ undefined == Just True +-- > Just False ||^ Just True == Just True +-- > Just False ||^ Just False == Just False +(||^) :: Monad m => m Bool -> m Bool -> m Bool (||^) a b = ifM a (return True) b + +-- | The lazy '&&' operator lifted to a monad. If the first +-- argument evaluates to 'False' the second argument will not +-- be evaluated. +-- +-- > Just False &&^ undefined == Just False +-- > Just True &&^ Just True == Just True +-- > Just True &&^ Just False == Just False +(&&^) :: Monad m => m Bool -> m Bool -> m Bool (&&^) a b = ifM a b (return False) +-- | A version of 'any' lifted to a moand. Retains the short-circuiting behaviour. +-- +-- > anyM Just [False,True ,undefined] == Just True +-- > anyM Just [False,False,undefined] == undefined +-- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM p [] = return False anyM p (x:xs) = ifM (p x) (return True) (anyM p xs) +-- | A version of 'all' lifted to a moand. Retains the short-circuiting behaviour. +-- +-- > allM Just [True,False,undefined] == Just False +-- > allM Just [True,True ,undefined] == undefined +-- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM p [] = return True allM p (x:xs) = ifM (p x) (allM p xs) (return False) +-- | A version of 'or' lifted to a moand. Retains the short-circuiting behaviour. +-- +-- > orM [Just False,Just True ,undefined] == Just True +-- > orM [Just False,Just False,undefined] == undefined +-- > \xs -> Just (or xs) == orM (map Just xs) orM :: Monad m => [m Bool] -> m Bool orM = anyM id +-- | A version of 'and' lifted to a moand. Retains the short-circuiting behaviour. +-- +-- > andM [Just True,Just False,undefined] == Just False +-- > andM [Just True,Just True ,undefined] == undefined +-- > \xs -> Just (and xs) == andM (map Just xs) andM :: Monad m => [m Bool] -> m Bool andM = allM id -- Searching +-- | Like 'find', but where the test can be monadic. +-- +-- > findM (Just . isUpper) "teST" == Just (Just 'S') +-- > findM (Just . isUpper) "test" == Just Nothing +-- > findM (Just . const True) ["x",undefined] == Just (Just "x") findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) findM p [] = return Nothing findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs) +-- | Like 'findM', but also allows you to compute some additional information in the predicate. firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstJustM p [] = return Nothing firstJustM p (x:xs) = maybe (firstJustM p xs) (return . Just) =<< p x 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 @@ -11,21 +11,37 @@ -- | The 'fromLeft' function extracts the element out of a 'Left' and -- throws an error if its argument is 'Right'. -- Much like 'fromJust', using this function in polished code is usually a bad idea. +-- +-- > \x -> fromLeft (Left x) == x +-- > \x -> fromLeft (Right x) == undefined fromLeft :: Either l r -> l fromLeft (Left x) = x -- | The 'fromRight' function extracts the element out of a 'Right' and -- throws an error if its argument is 'Left'. -- Much like 'fromJust', using this function in polished code is usually a bad idea. +-- +-- > \x -> fromRight (Right x) == x +-- > \x -> fromRight (Left x) == undefined fromRight :: Either l r -> r fromRight (Right x) = x #if __GLASGOW_HASKELL__ < 708 +-- | Test if an 'Either' value is the 'Left' constructor. +-- Provided as standard with GHC 7.8 and above. +isLeft :: Either l r -> Bool isLeft Left{} = True; isLeft _ = False + +-- | Test if an 'Either' value is the 'Right' constructor. +-- Provided as standard with GHC 7.8 and above. +isRight :: Either l r -> Bool isRight Right{} = True; isRight _ = False #endif -- | Pull the value out of an 'Either' where both alternatives -- have the same type. +-- +-- > \x -> fromEither (Left x ) == x +-- > \x -> fromEither (Right x) == x fromEither :: Either a a -> a fromEither = either id id 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 @@ -52,8 +52,14 @@ -- -- > anySame [1,1,2] == True -- > anySame [1,2,3] == False +-- > anySame (1:2:1:undefined) == True +-- > anySame [] == False +-- > \xs -> anySame xs == (length (nub xs) < length xs) anySame :: Eq a => [a] -> Bool -anySame xs = length xs /= length (nub xs) +anySame = f [] + where + f seen (x:xs) = x `elem` seen || f (x:seen) xs + f seen [] = False -- | Are all elements the same. -- @@ -61,27 +67,53 @@ -- > allSame [1,1,1] == True -- > allSame [1] == True -- > allSame [] == True +-- > allSame (1:1:2:undefined) == False +-- > \xs -> allSame xs == (length (nub xs) <= 1) allSame :: Eq a => [a] -> Bool -allSame xs = length (nub xs) <= 1 +allSame [] = True +allSame (x:xs) = all (x ==) xs +-- | Non-recursive transform over a list, like 'maybe'. +-- +-- > list 1 (\v _ -> v - 2) [5,6,7] == 3 +-- > list 1 (\v _ -> v - 2) [] == 1 +-- > \nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs list :: b -> (a -> [a] -> b) -> [a] -> b list nil cons [] = nil list nil cons (x:xs) = cons x xs +-- | If the list is empty returns 'Nothing', otherwise returns the 'head' and the 'tail'. +-- +-- > uncons "test" == Just ('t',"est") +-- > uncons "" == Nothing +-- > \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs) uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing uncons (x:xs) = Just (x,xs) +-- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. +-- +-- > unsnoc "test" == Just ("tes",'t') +-- > unsnoc "" == Nothing +-- > \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc [x] = Just ([], x) unsnoc (x:xs) = Just (x:a, b) where Just (a,b) = unsnoc xs +-- | Append an element to the start of a list, an alias for '(:)'. +-- +-- > cons 't' "est" == "test" +-- > \x xs -> uncons (cons x xs) == Just (x,xs) cons :: a -> [a] -> [a] cons = (:) +-- | Append an element to the end of a list, takes /O(n)/ time. +-- +-- > snoc "tes" 't' == "test" +-- > \xs x -> unsnoc (snoc xs x) == Just (xs,x) snoc :: [a] -> a -> [a] snoc xs x = xs ++ [x] @@ -161,9 +193,9 @@ -- | Break, but from the end. -- --- > breakEnd isLower "youRE" === ("you","RE") --- > breakEnd isLower "youre" === ("youre","") --- > breakEnd isLower "YOURE" === ("","YOURE") +-- > breakEnd isLower "youRE" == ("you","RE") +-- > breakEnd isLower "youre" == ("youre","") +-- > breakEnd isLower "YOURE" == ("","YOURE") breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) breakEnd f = swap . both reverse . break f . reverse @@ -294,7 +326,7 @@ -- > chunksOf 3 "my test" == ["my ","tes","t"] -- > chunksOf 3 "mytest" == ["myt","est"] -- > chunksOf 8 "" == [] --- > chunksOf 0 "test" == error +-- > chunksOf 0 "test" == undefined chunksOf :: 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/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables #-} module TestGen(tests) where import TestUtil -default(Maybe Bool,Int,Double) +default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do testGen "stringException (\"test\" ++ undefined) == return \"test\"" $ stringException ("test" ++ undefined) == return "test" @@ -16,8 +16,33 @@ testGen "\\(x :: Maybe ()) -> unit x == x" $ \(x :: Maybe ()) -> unit x == x testGen "partitionM (Just . even) [1,2,3] == Just ([2], [1,3])" $ partitionM (Just . even) [1,2,3] == Just ([2], [1,3]) testGen "partitionM (const Nothing) [1,2,3] == Nothing" $ partitionM (const Nothing) [1,2,3] == Nothing - testGen "Just False &&^ undefined == Just False" $ Just False &&^ undefined == Just False - testGen "Just True &&^ Just True == Just True" $ Just True &&^ Just True == Just True + testGen "Just True ||^ undefined == Just True" $ Just True ||^ undefined == Just True + testGen "Just False ||^ Just True == Just True" $ Just False ||^ Just True == Just True + testGen "Just False ||^ Just False == Just False" $ Just False ||^ Just False == Just False + testGen "Just False &&^ undefined == Just False" $ Just False &&^ undefined == Just False + testGen "Just True &&^ Just True == Just True" $ Just True &&^ Just True == Just True + testGen "Just True &&^ Just False == Just False" $ Just True &&^ Just False == Just False + testGen "anyM Just [False,True ,undefined] == Just True" $ anyM Just [False,True ,undefined] == Just True + testGen "anyM Just [False,False,undefined] == undefined" $ erroneous $ anyM Just [False,False,undefined] + testGen "\\(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)" $ \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) + testGen "allM Just [True,False,undefined] == Just False" $ allM Just [True,False,undefined] == Just False + testGen "allM Just [True,True ,undefined] == undefined" $ erroneous $ allM Just [True,True ,undefined] + testGen "\\(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)" $ \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) + testGen "orM [Just False,Just True ,undefined] == Just True" $ orM [Just False,Just True ,undefined] == Just True + testGen "orM [Just False,Just False,undefined] == undefined" $ erroneous $ orM [Just False,Just False,undefined] + testGen "\\xs -> Just (or xs) == orM (map Just xs)" $ \xs -> Just (or xs) == orM (map Just xs) + testGen "andM [Just True,Just False,undefined] == Just False" $ andM [Just True,Just False,undefined] == Just False + testGen "andM [Just True,Just True ,undefined] == undefined" $ erroneous $ andM [Just True,Just True ,undefined] + testGen "\\xs -> Just (and xs) == andM (map Just xs)" $ \xs -> Just (and xs) == andM (map Just xs) + testGen "findM (Just . isUpper) \"teST\" == Just (Just 'S')" $ findM (Just . isUpper) "teST" == Just (Just 'S') + testGen "findM (Just . isUpper) \"test\" == Just Nothing" $ findM (Just . isUpper) "test" == Just Nothing + testGen "findM (Just . const True) [\"x\",undefined] == Just (Just \"x\")" $ findM (Just . const True) ["x",undefined] == Just (Just "x") + testGen "\\x -> fromLeft (Left x) == x" $ \x -> fromLeft (Left x) == x + testGen "\\x -> fromLeft (Right x) == undefined" $ \x -> erroneous $ fromLeft (Right x) + testGen "\\x -> fromRight (Right x) == x" $ \x -> fromRight (Right x) == x + testGen "\\x -> fromRight (Left x) == undefined" $ \x -> erroneous $ fromRight (Left x) + testGen "\\x -> fromEither (Left x ) == x" $ \x -> fromEither (Left x ) == x + testGen "\\x -> fromEither (Right x) == x" $ \x -> fromEither (Right x) == x testGen "\\xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs" $ \xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs testGen "\\xs -> repeatedly word1 (trim xs) == words xs" $ \xs -> repeatedly word1 (trim xs) == words xs testGen "for [1,2,3] (+1) == [2,3,4]" $ for [1,2,3] (+1) == [2,3,4] @@ -25,15 +50,33 @@ testGen "disjoint [1,2,3] [4,1] == False" $ disjoint [1,2,3] [4,1] == False testGen "anySame [1,1,2] == True" $ anySame [1,1,2] == True testGen "anySame [1,2,3] == False" $ anySame [1,2,3] == False + testGen "anySame (1:2:1:undefined) == True" $ anySame (1:2:1:undefined) == True + testGen "anySame [] == False" $ anySame [] == False + testGen "\\xs -> anySame xs == (length (nub xs) < length xs)" $ \xs -> anySame xs == (length (nub xs) < length xs) testGen "allSame [1,1,2] == False" $ allSame [1,1,2] == False testGen "allSame [1,1,1] == True" $ allSame [1,1,1] == True testGen "allSame [1] == True" $ allSame [1] == True testGen "allSame [] == True" $ allSame [] == True + testGen "allSame (1:1:2:undefined) == False" $ allSame (1:1:2:undefined) == False + testGen "\\xs -> allSame xs == (length (nub xs) <= 1)" $ \xs -> allSame xs == (length (nub xs) <= 1) + testGen "list 1 (\\v _ -> v - 2) [5,6,7] == 3" $ list 1 (\v _ -> v - 2) [5,6,7] == 3 + testGen "list 1 (\\v _ -> v - 2) [] == 1" $ list 1 (\v _ -> v - 2) [] == 1 + testGen "\\nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs" $ \nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs + testGen "uncons \"test\" == Just ('t',\"est\")" $ uncons "test" == Just ('t',"est") + testGen "uncons \"\" == Nothing" $ uncons "" == Nothing + testGen "\\xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs)" $ \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs) + testGen "unsnoc \"test\" == Just (\"tes\",'t')" $ unsnoc "test" == Just ("tes",'t') + testGen "unsnoc \"\" == Nothing" $ unsnoc "" == Nothing + testGen "\\xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs)" $ \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) + testGen "cons 't' \"est\" == \"test\"" $ cons 't' "est" == "test" + testGen "\\x xs -> uncons (cons x xs) == Just (x,xs)" $ \x xs -> uncons (cons x xs) == Just (x,xs) + testGen "snoc \"tes\" 't' == \"test\"" $ snoc "tes" 't' == "test" + testGen "\\xs x -> unsnoc (snoc xs x) == Just (xs,x)" $ \xs x -> unsnoc (snoc xs x) == Just (xs,x) testGen "lower \"This is A TEST\" == \"this is a test\"" $ lower "This is A TEST" == "this is a test" testGen "lower \"\" == \"\"" $ lower "" == "" - testGen "breakEnd isLower \"youRE\" === (\"you\",\"RE\")" $ breakEnd isLower "youRE" === ("you","RE") - testGen "breakEnd isLower \"youre\" === (\"youre\",\"\")" $ breakEnd isLower "youre" === ("youre","") - testGen "breakEnd isLower \"YOURE\" === (\"\",\"YOURE\")" $ breakEnd isLower "YOURE" === ("","YOURE") + testGen "breakEnd isLower \"youRE\" == (\"you\",\"RE\")" $ breakEnd isLower "youRE" == ("you","RE") + testGen "breakEnd isLower \"youre\" == (\"youre\",\"\")" $ breakEnd isLower "youre" == ("youre","") + testGen "breakEnd isLower \"YOURE\" == (\"\",\"YOURE\")" $ breakEnd isLower "YOURE" == ("","YOURE") testGen "spanEnd isUpper \"youRE\" == (\"you\",\"RE\")" $ spanEnd isUpper "youRE" == ("you","RE") testGen "spanEnd (not . isSpace) \"x y z\" == (\"x y \",\"z\")" $ spanEnd (not . isSpace) "x y z" == ("x y ","z") testGen "\\f xs-> spanEnd f xs == swap (both reverse (span f (reverse xs)))" $ \f xs-> spanEnd f xs == swap (both reverse (span f (reverse xs))) @@ -55,7 +98,7 @@ testGen "chunksOf 3 \"my test\" == [\"my \",\"tes\",\"t\"]" $ chunksOf 3 "my test" == ["my ","tes","t"] testGen "chunksOf 3 \"mytest\" == [\"myt\",\"est\"]" $ chunksOf 3 "mytest" == ["myt","est"] testGen "chunksOf 8 \"\" == []" $ chunksOf 8 "" == [] - testGen "chunksOf 0 \"test\" == error" $ erroneous $ chunksOf 0 "test" + testGen "chunksOf 0 \"test\" == undefined" $ erroneous $ chunksOf 0 "test" testGen "showDP 4 pi == \"3.1416\"" $ showDP 4 pi == "3.1416" testGen "showDP 0 pi == \"3\"" $ showDP 0 pi == "3" testGen "showDP 2 3 == \"3.00\"" $ showDP 2 3 == "3.00"