extra 0.3.1 → 0.3.2

raw patch · 8 files changed

+232/−19 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGES.txt +2/−0
• Generate.hs +68/−0
• extra.cabal +2/−1
• src/Control/Concurrent/Extra.hs +1/−1
• src/Control/Monad/Extra.hs +55/−4
• src/Data/Either/Extra.hs +16/−0
• src/Data/List/Extra.hs +38/−6
• test/TestGen.hs +50/−7

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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<Exception>\"" $ stringException ("test" ++ undefined)            == return "test<Exception>"@@ -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"