diff --git a/src/Data/Bool/HT.hs b/src/Data/Bool/HT.hs --- a/src/Data/Bool/HT.hs +++ b/src/Data/Bool/HT.hs @@ -1,5 +1,6 @@ module Data.Bool.HT ( B.if', + B.ifThenElse, B.select, (B.?:), B.implies, diff --git a/src/Data/Bool/HT/Private.hs b/src/Data/Bool/HT/Private.hs --- a/src/Data/Bool/HT/Private.hs +++ b/src/Data/Bool/HT/Private.hs @@ -18,6 +18,15 @@ if' False _ y = y {-| +The same as 'if'', but the name is chosen +such that it can be used for GHC-7.0's rebindable if-then-else syntax. +-} +{-# INLINE ifThenElse #-} +ifThenElse :: Bool -> a -> a -> a +ifThenElse = if' + + +{-| From a list of expressions choose the one, whose condition is true. diff --git a/src/Data/Function/HT/Private.hs b/src/Data/Function/HT/Private.hs --- a/src/Data/Function/HT/Private.hs +++ b/src/Data/Function/HT/Private.hs @@ -37,9 +37,9 @@ (a -> a -> a) -> a -> a -> Integer -> a powerAssociative _ a0 _ 0 = a0 powerAssociative op a0 a n = - if even n - then powerAssociative op a0 (op a a) (div n 2) - else powerAssociative op (op a0 a) (op a a) (div n 2) + powerAssociative op + (if even n then a0 else (op a0 a)) + (op a a) (div n 2) powerAssociative1 op a0 a n = foldr op a0 (genericReplicate n a) diff --git a/src/Data/List/HT/Private.hs b/src/Data/List/HT/Private.hs --- a/src/Data/List/HT/Private.hs +++ b/src/Data/List/HT/Private.hs @@ -4,7 +4,7 @@ findIndices, foldl', ) import Data.Maybe as Maybe (fromMaybe, catMaybes, ) import Data.Maybe.HT (toMaybe, ) -import Control.Monad (guard, ) +import Control.Monad (guard, msum, ) import Data.Tuple.HT (mapPair, mapFst, mapSnd, forcePair, ) import qualified Data.List.Key.Private as Key @@ -137,7 +137,24 @@ {- | Split the list at the occurrences of a separator into sub-lists. Remove the separators. -This is a generalization of 'words'. +This is somehow a generalization of 'lines' and 'words'. +But note the differences: + +> Prelude Data.List.HT> words "a a" +> ["a","a"] +> Prelude Data.List.HT> chop (' '==) "a a" +> ["a","","a"] + +> Prelude Data.List.HT> lines "a\n\na" +> ["a","","a"] +> Prelude Data.List.HT> chop ('\n'==) "a\n\na" +> ["a","","a"] + +> Prelude Data.List.HT> lines "a\n" +> ["a"] +> Prelude Data.List.HT> chop ('\n'==) "a\n" +> ["a",""] + -} chop :: (a -> Bool) -> [a] -> [[a]] chop p = @@ -268,8 +285,12 @@ splitEverywhere :: [a] -> [([a], a, [a])] splitEverywhere xs = - map (\(y, z:zs) -> (y,z,zs)) - (init (zip (inits xs) (tails xs))) + map + (\(y, zs0) -> + case zs0 of + z:zs -> (y,z,zs) + [] -> error "splitEverywhere: empty list") + (init (zip (inits xs) (tails xs))) @@ -493,6 +514,16 @@ search :: (Eq a) => [a] -> [a] -> [Int] search sub str = findIndices (isPrefixOf sub) (tails str) +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace src dst = + let recourse [] = [] + recourse str@(s:ss) = + fromMaybe + (s : recourse ss) + (fmap ((dst++) . recourse) $ + maybePrefixOf src str) + in recourse + markSublists :: (Eq a) => [a] -> [a] -> [Maybe [a]] markSublists sub ys = let ~(hd', rest') = @@ -503,8 +534,8 @@ Nothing -> (xs, rest)) ([],[]) ys in Just hd' : rest' -replace :: (Eq a) => [a] -> [a] -> [a] -> [a] -replace src dst xs = +replace' :: (Eq a) => [a] -> [a] -> [a] -> [a] +replace' src dst xs = concatMap (fromMaybe dst) (markSublists src xs) propReplaceId :: (Eq a) => [a] -> [a] -> Bool @@ -519,8 +550,8 @@ That's also the reason for inefficiency: The replacing can go on only when subsequent replacements are finished. Thus this functiob fails on infinite lists. -} -replace' :: (Eq a) => [a] -> [a] -> [a] -> [a] -replace' src dst = +replace'' :: (Eq a) => [a] -> [a] -> [a] -> [a] +replace'' src dst = foldr (\x xs -> let y=x:xs in if isPrefixOf src y then dst ++ drop (length src) y @@ -530,6 +561,18 @@ multiReplace dict = let recourse [] = [] recourse str@(s:ss) = + fromMaybe + (s : recourse ss) + (msum $ + map (\(src,dst) -> + fmap ((dst++) . recourse) $ + maybePrefixOf src str) dict) + in recourse + +multiReplace' :: Eq a => [([a], [a])] -> [a] -> [a] +multiReplace' dict = + let recourse [] = [] + recourse str@(s:ss) = maybe (s : recourse ss) (\(src, dst) -> dst ++ recourse (Match.drop src str)) @@ -724,6 +767,41 @@ {- Debug.QuickCheck.quickCheck (\b d -> propFoldl'r (+) (b::Int) (++) (d::[Int])) -} + + +{- +Iterate until elements start to cycle. +This implementation is inspired by Elements of Programming +but I am still not satisfied +where the iteration actually stops. +-} +iterateUntilCycle :: (Eq a) => (a -> a) -> a -> [a] +iterateUntilCycle f a = + let as = iterate f a + in (a:) $ map fst $ + takeWhile (uncurry (/=)) $ + zip (tail as) (concatMap (\ai->[ai,ai]) as) + +{- +iterateUntilCycleQ :: (Eq a) => (a -> a) -> a -> [a] +iterateUntilCycleQ f a = + let as = tail $ iterate f a + in (a:) $ map fst $ + takeWhile (uncurry (/=)) $ + zip as (downsample2 (tail as)) +-} + +iterateUntilCycleP :: (Eq a) => (a -> a) -> a -> [a] +iterateUntilCycleP f a = + let as = iterate f a + in map fst $ + takeWhile (\(a1,(a20,a21)) -> a1/=a20 && a1/=a21) $ + zip as (pairs (tail as)) + +pairs :: [t] -> [(t, t)] +pairs [] = [] +pairs (_:[]) = error "pairs: odd number of elements" +pairs (x0:x1:xs) = (x0,x1) : pairs xs {- | rotate left -} diff --git a/src/Data/List/Match/Private.hs b/src/Data/List/Match/Private.hs --- a/src/Data/List/Match/Private.hs +++ b/src/Data/List/Match/Private.hs @@ -21,52 +21,42 @@ {- | Drop as many elements as the first list is long -} drop :: [b] -> [a] -> [a] -drop xs ys = +drop xs ys0 = + foldl (\ys _ -> laxTail ys) ys0 xs + +{- +Shares suffix with input, +that is it is more efficient than the implementations below. +-} +dropRec :: [b] -> [a] -> [a] +dropRec (_:xs) (_:ys) = dropRec xs ys +dropRec _ ys = ys + +drop0 :: [b] -> [a] -> [a] +drop0 xs ys = -- catMaybes ( map fromJust (dropWhile isNothing (zipWith (toMaybe . null) (iterate laxTail xs) ys)) -drop' :: [b] -> [a] -> [a] -drop' xs ys = +drop1 :: [b] -> [a] -> [a] +drop1 xs ys = map snd (dropWhile (not . null . fst) (zip (iterate laxTail xs) ys)) -drop'' :: [b] -> [a] -> [a] -drop'' xs ys = +drop2 :: [b] -> [a] -> [a] +drop2 xs ys = snd $ head $ dropWhile (not . null . fst) $ zip (iterate laxTail xs) (iterate laxTail ys) -{- | -Shares suffix with input, that is it is more efficient. --} -drop''' :: [b] -> [a] -> [a] -drop''' (_:xs) (_:ys) = drop''' xs ys -drop''' _ ys = ys {- | @laxTail [] = []@ -} laxTail :: [a] -> [a] -laxTail = List.drop 1 - -propTake :: (Eq a) => [b] -> [a] -> Bool -propTake xs ys = - take xs ys == List.take (length xs) ys - -propDrop :: (Eq a) => [b] -> [a] -> Bool -propDrop xs ys = - drop xs ys == List.drop (length xs) ys - -propDropAlt :: (Eq a) => [b] -> [a] -> Bool -propDropAlt xs ys = - drop xs ys == drop' xs ys && - drop xs ys == drop'' xs ys && - drop xs ys == drop''' xs ys - -propTakeDrop :: (Eq a) => [b] -> [a] -> Bool -propTakeDrop xs ys = - take xs ys ++ drop xs ys == ys +laxTail xt = case xt of [] -> []; _:xs -> xs +laxTail0 :: [a] -> [a] +laxTail0 = List.drop 1 splitAt :: [b] -> [a] -> ([a],[a]) splitAt nt xt = @@ -75,11 +65,7 @@ (_:ns, x:xs) -> mapFst (x:) $ splitAt ns xs (_, xs) -> ([],xs) -propSplitAt :: (Eq a) => [b] -> [a] -> Bool -propSplitAt xs ys = - (take xs ys, drop xs ys) == splitAt xs ys - {- | Compare the length of two lists over different types. It is equivalent to @(compare (length xs) (length ys))@ @@ -92,21 +78,16 @@ compareLength [] (_:_) = LT {- | efficient like compareLength, but without pattern matching -} -compareLength' :: [a] -> [b] -> Ordering -compareLength' xs ys = +compareLength0 :: [a] -> [b] -> Ordering +compareLength0 xs ys = let boolList zs = replicate zs True ++ repeat False -- we rely in the order of Bool constructors False and True here in uncurry compare (head (dropWhile (uncurry (&&)) (zip (boolList xs) (boolList ys)))) -compareLength'' :: [a] -> [b] -> Ordering -compareLength'' xs ys = +compareLength1 :: [a] -> [b] -> Ordering +compareLength1 xs ys = compare (length xs) (length ys) - -propCompareLength :: [Integer] -> [Int] -> Bool -propCompareLength xs ys = - compareLength xs ys == compareLength' xs ys && - compareLength xs ys == compareLength'' xs ys {- | @lessOrEqualLength x y@ is almost the same as @compareLength x y <= EQ@, diff --git a/src/Data/Maybe/HT.hs b/src/Data/Maybe/HT.hs --- a/src/Data/Maybe/HT.hs +++ b/src/Data/Maybe/HT.hs @@ -3,7 +3,10 @@ import Data.Maybe (fromMaybe, ) import Control.Monad (msum, ) - +{- +It was proposed as addition to Data.Maybe and rejected at that time. + +-} {- | Returns 'Just' if the precondition is fulfilled. -} {-# INLINE toMaybe #-} toMaybe :: Bool -> a -> Maybe a diff --git a/src/Data/Monoid/HT.hs b/src/Data/Monoid/HT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/HT.hs @@ -0,0 +1,14 @@ +module Data.Monoid.HT (cycle, ) where + +import Data.Monoid (Monoid, mappend, ) +import Data.Function (fix, ) + +import Prelude () + + +{- | +Generalization of 'Data.List.cycle' to any monoid. +-} +cycle :: Monoid m => m -> m +cycle x = + fix (mappend x) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -1,7 +1,9 @@ module Main where -import qualified Test.Data.List as ListHT -import qualified Test.Data.Function as FunctionHT +import qualified Test.Data.List as ListHT +import qualified Test.Data.ListMatch as ListMatch +import qualified Test.Data.Maybe as MaybeHT +import qualified Test.Data.Function as FunctionHT prefix :: String -> [(String, IO ())] -> [(String, IO ())] @@ -12,6 +14,8 @@ main = mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ concat $ - prefix "List" ListHT.tests : - prefix "Function" FunctionHT.tests : + prefix "List" ListHT.tests : + prefix "ListMatch" ListMatch.tests : + prefix "Maybe" MaybeHT.tests : + prefix "Function" FunctionHT.tests : [] diff --git a/src/Test/Data/Function.hs b/src/Test/Data/Function.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/Function.hs @@ -0,0 +1,18 @@ +module Test.Data.Function where + +import qualified Data.Function.HT.Private as FuncHT + +import Test.QuickCheck (Property, quickCheck, (==>), ) + + +powerAssociative :: Eq a => + (a -> a -> a) -> a -> a -> Integer -> Property +powerAssociative op a0 a n = + n>0 ==> + FuncHT.powerAssociative op a0 a n == FuncHT.powerAssociative1 op a0 a n + + +tests :: [(String, IO ())] +tests = + ("powerAssociative", quickCheck (powerAssociative (+) :: Integer -> Integer -> Integer -> Property)) : + [] diff --git a/src/Test/Data/List.hs b/src/Test/Data/List.hs --- a/src/Test/Data/List.hs +++ b/src/Test/Data/List.hs @@ -5,7 +5,7 @@ import Control.Monad (liftM2, ) import Test.Utility (equalLists, equalInfLists, ) -import Test.QuickCheck (Property, test, (==>), ) +import Test.QuickCheck (Testable, Property, quickCheck, (==>), ) import Prelude hiding (iterate, ) @@ -20,10 +20,10 @@ ListHT.sieve''' n x] -sliceHorizontal :: Eq a => Int -> [a] -> Property -sliceHorizontal n x = - n>0 ==> - ListHT.sliceHorizontal n x == ListHT.sliceHorizontal' n x +sliceHorizontal :: Eq a => Int -> [a] -> Bool +sliceHorizontal n0 x = + let n = 1 + mod n0 1000 + in ListHT.sliceHorizontal n x == ListHT.sliceHorizontal' n x sliceVertical :: Eq a => Int -> [a] -> Property @@ -31,12 +31,13 @@ n>0 ==> ListHT.sliceVertical n x == ListHT.sliceVertical' n x -slice :: Eq a => Int -> [a] -> Property -slice n x = - 0 - -- problems: ListHT.sliceHorizontal 4 [] == [[],[],[],[]] - ListHT.sliceHorizontal n x == List.transpose (ListHT.sliceVertical n x) && - ListHT.sliceVertical n x == List.transpose (ListHT.sliceHorizontal n x) +slice :: Eq a => Int -> [a] -> a -> Bool +slice n0 as a = + let x = a:as + n = 1 + mod n0 (length x) + in -- problems: ListHT.sliceHorizontal 4 [] == [[],[],[],[]] + ListHT.sliceHorizontal n x == List.transpose (ListHT.sliceVertical n x) && + ListHT.sliceVertical n x == List.transpose (ListHT.sliceHorizontal n x) @@ -62,14 +63,19 @@ +simple :: + (Testable test) => + (Int -> [Integer] -> test) -> IO () +simple = quickCheck + tests :: [(String, IO ())] tests = - ("sieve", test (sieve :: Int -> [Integer] -> Property)) : - ("sliceHorizontal", test (sliceHorizontal :: Int -> [Integer] -> Property)) : - ("sliceVertical", test (sliceVertical :: Int -> [Integer] -> Property)) : - ("slice", test (slice :: Int -> [Integer] -> Property)) : - ("shear", test (shear :: [[Integer]] -> Bool)) : - ("outerProduct", test (outerProduct :: [Integer] -> [Int] -> Bool)) : - ("iterate", test (iterate (+) :: Integer -> Bool)) : + ("sieve", simple sieve) : + ("sliceHorizontal", simple sliceHorizontal) : + ("sliceVertical", simple sliceVertical) : + ("slice", simple slice) : + ("shear", quickCheck (shear :: [[Integer]] -> Bool)) : + ("outerProduct", quickCheck (outerProduct :: [Integer] -> [Int] -> Bool)) : + ("iterate", quickCheck (iterate (+) :: Integer -> Bool)) : [] diff --git a/src/Test/Data/ListMatch.hs b/src/Test/Data/ListMatch.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/ListMatch.hs @@ -0,0 +1,66 @@ +module Test.Data.ListMatch where + +import qualified Data.List.Match.Private as Match +import qualified Data.List as List + +import Test.Utility (equalLists, ) +import Test.QuickCheck (Testable, quickCheck, ) + +import Prelude hiding (iterate, take, drop, splitAt, ) + + + +laxTail :: (Eq a) => [a] -> Bool +laxTail xs = + Match.laxTail xs == Match.laxTail0 xs + +take :: (Eq a) => [b] -> [a] -> Bool +take xs ys = + Match.take xs ys == List.take (length xs) ys + +drop :: (Eq a) => [b] -> [a] -> Bool +drop xs ys = + Match.drop xs ys == List.drop (length xs) ys + +dropAlt :: (Eq a) => [b] -> [a] -> Bool +dropAlt xs ys = + equalLists $ + Match.drop xs ys : + Match.drop0 xs ys : + Match.drop1 xs ys : + Match.drop2 xs ys : + Match.dropRec xs ys : + [] + +takeDrop :: (Eq a) => [b] -> [a] -> Bool +takeDrop xs ys = + Match.take xs ys ++ Match.drop xs ys == ys + +splitAt :: (Eq a) => [b] -> [a] -> Bool +splitAt xs ys = + (Match.take xs ys, Match.drop xs ys) == Match.splitAt xs ys + + +compareLength :: [a] -> [b] -> Bool +compareLength xs ys = + Match.compareLength xs ys == Match.compareLength0 xs ys && + Match.compareLength xs ys == Match.compareLength1 xs ys + + +test1 :: Testable test => ([Int] -> test) -> IO () +test1 = quickCheck + +test2 :: Testable test => ([Int] -> [Integer] -> test) -> IO () +test2 = quickCheck + + +tests :: [(String, IO ())] +tests = + ("laxTail", test1 laxTail) : + ("take", test2 take) : + ("drop", test2 drop) : + ("dropAlt", test2 dropAlt) : + ("takeDrop", test2 takeDrop) : + ("splitAt", test2 splitAt) : + ("compareLength", test2 compareLength) : + [] diff --git a/src/Test/Data/Maybe.hs b/src/Test/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/Maybe.hs @@ -0,0 +1,17 @@ +module Test.Data.Maybe where + +import Control.Monad (guard, ) +import Data.Maybe.HT (toMaybe, ) + +import Test.QuickCheck (quickCheck, ) + + +toMaybeGuard :: Eq a => Bool -> Maybe a -> Bool +toMaybeGuard b x = + (guard b >> x) == (toMaybe b =<< x) + + +tests :: [(String, IO ())] +tests = + ("toMaybeGuard", quickCheck (\b x -> toMaybeGuard b (x::Maybe Int))) : + [] diff --git a/src/Text/Show/HT.hs b/src/Text/Show/HT.hs --- a/src/Text/Show/HT.hs +++ b/src/Text/Show/HT.hs @@ -2,11 +2,22 @@ {-| Show a value using an infix operator. -} {-# INLINE showsInfixPrec #-} -showsInfixPrec :: (Show a, Show b) => - String -> Int -> Int -> a -> b -> ShowS +showsInfixPrec :: + (Show a, Show b) => + String -> Int -> Int -> a -> b -> ShowS showsInfixPrec opStr opPrec prec x y = showParen (prec >= opPrec) (showsPrec opPrec x . showString " " . showString opStr . showString " " . showsPrec opPrec y) + +concatS :: [ShowS] -> ShowS +concatS = flip (foldr ($)) + +{- +precedences + +appPrec :: Int +appPrec = 10 +-} diff --git a/utility-ht.cabal b/utility-ht.cabal --- a/utility-ht.cabal +++ b/utility-ht.cabal @@ -1,5 +1,5 @@ Name: utility-ht -Version: 0.0.5.1 +Version: 0.0.6 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -11,12 +11,15 @@ Various small helper functions for Lists, Maybes, Tuples, Functions. Some of these functions are improved implementations of standard functions. They have the same name as their standard counterparts. - - The package only contains functions - that do not require packages other than the base package. + . + All modules are plain Haskell 98. + The package depends exclusively on the @base@ package + and only that portions of @base@ that are simple to port. Thus you do not risk a dependency avalanche by importing it. However, further splitting the base package might invalidate this statement. -Tested-With: GHC==6.8.2 + . + Alternative packages: @Useful@, @MissingH@ +Tested-With: GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.2 Cabal-Version: >=1.6 Build-Type: Simple @@ -27,14 +30,15 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/utility/ - tag: 0.0.5.1 + tag: 0.0.6 Flag buildTests description: Build test executables default: False Library - Build-Depends: base + Build-Depends: + base >=3 && <5 GHC-Options: -Wall Hs-Source-Dirs: src @@ -46,6 +50,7 @@ Data.List.Key Data.List.Match Data.Maybe.HT + Data.Monoid.HT Data.Ord.HT Data.Record.HT Data.String.HT @@ -65,12 +70,15 @@ Executable test If flag(buildTests) - Build-Depends: QuickCheck >=1.1 && <2 + Build-Depends: QuickCheck >=1.1 && <3 Else Buildable: False GHC-Options: -Wall Hs-source-dirs: src Other-Modules: Test.Data.List + Test.Data.ListMatch + Test.Data.Maybe + Test.Data.Function Test.Utility Main-Is: Test.hs