utility-ht-0.0.11/0000755000000000000000000000000012565100162012071 5ustar0000000000000000utility-ht-0.0.11/LICENSE0000644000000000000000000000272112565100162013100 0ustar0000000000000000Copyright (c) 2009, Henning Thielemann All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. utility-ht-0.0.11/utility-ht.cabal0000644000000000000000000000544312565100162015177 0ustar0000000000000000Name: utility-ht Version: 0.0.11 License: BSD3 License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann -- Homepage: http://www.haskell.org/haskellwiki/Utility-HT Category: Data, List Synopsis: Various small helper functions for Lists, Maybes, Tuples, Functions Description: 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. Others are equivalent to functions from the @base@ package, but if you import them from this utility package then you can write code that runs on older GHC versions or other compilers like Hugs and JHC. . 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. . Alternative packages: @Useful@, @MissingH@ Tested-With: GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 Tested-With: GHC==7.0.2, GHC==7.2.2, GHC==7.4.1, GHC==7.8.2 Cabal-Version: >=1.10 Build-Type: Simple -- workaround for Cabal-1.10 Extra-Source-Files: src/Test/Data/Maybe.hs src/Test/Data/ListMatch.hs src/Test/Data/Function.hs src/Test/Data/List.hs src/Test/Utility.hs src/Test.hs Source-Repository head type: darcs location: http://code.haskell.org/~thielema/utility/ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/utility/ tag: 0.0.11 Library Build-Depends: base >=2 && <5 Default-Language: Haskell98 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Data.Bool.HT Data.Eq.HT Data.Function.HT Data.Ix.Enum Data.List.HT Data.List.Key Data.List.Match Data.Maybe.HT Data.Monoid.HT Data.Ord.HT Data.Record.HT Data.String.HT Data.Tuple.HT Data.Tuple.Lazy Data.Tuple.Strict Control.Monad.HT Control.Functor.HT Data.Strictness.HT Text.Read.HT Text.Show.HT Other-Modules: Data.Bool.HT.Private Data.List.HT.Private Data.List.Key.Private Data.List.Match.Private Data.Function.HT.Private Data.Record.HT.Private Data.Tuple.Example Test-Suite test Type: exitcode-stdio-1.0 Build-Depends: QuickCheck >=1.1 && <3, base >=3 && <5 Default-Language: Haskell98 Main-Is: Test.hs GHC-Options: -Wall Hs-source-dirs: src Other-Modules: Test.Data.List Test.Data.ListMatch Test.Data.Maybe Test.Data.Function Test.Utility utility-ht-0.0.11/Setup.lhs0000644000000000000000000000011512565100162013676 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain utility-ht-0.0.11/src/0000755000000000000000000000000012565100162012660 5ustar0000000000000000utility-ht-0.0.11/src/Test.hs0000644000000000000000000000113112565100162014127 0ustar0000000000000000module Main where 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 ())] prefix msg = map (\(str,test) -> (msg ++ "." ++ str, test)) main :: IO () main = mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ concat $ prefix "List" ListHT.tests : prefix "ListMatch" ListMatch.tests : prefix "Maybe" MaybeHT.tests : prefix "Function" FunctionHT.tests : [] utility-ht-0.0.11/src/Test/0000755000000000000000000000000012565100162013577 5ustar0000000000000000utility-ht-0.0.11/src/Test/Utility.hs0000644000000000000000000000070112565100162015574 0ustar0000000000000000-- cf. Test.NumericPrelude.Utility module Test.Utility where import Data.List.HT (mapAdjacent, ) import qualified Data.List as List -- compare the lists simultaneously equalLists :: Eq a => [[a]] -> Bool equalLists xs = let equalElems ys = and (mapAdjacent (==) ys) && length xs == length ys in all equalElems (List.transpose xs) equalInfLists :: Eq a => Int -> [[a]] -> Bool equalInfLists n xs = equalLists (map (take n) xs) utility-ht-0.0.11/src/Test/Data/0000755000000000000000000000000012565100162014450 5ustar0000000000000000utility-ht-0.0.11/src/Test/Data/Maybe.hs0000644000000000000000000000055212565100162016043 0ustar0000000000000000module 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))) : [] utility-ht-0.0.11/src/Test/Data/ListMatch.hs0000644000000000000000000000367012565100162016702 0ustar0000000000000000module 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 takeRev :: (Eq a) => [b] -> [a] -> Bool takeRev xs ys = Match.takeRev xs ys == reverse (Match.take xs (reverse ys)) dropRev :: (Eq a) => [b] -> [a] -> Bool dropRev xs ys = Match.dropRev xs ys == reverse (Match.drop xs (reverse 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) : ("takeRev", test2 takeRev) : ("dropRev", test2 dropRev) : ("compareLength", test2 compareLength) : [] utility-ht-0.0.11/src/Test/Data/Function.hs0000644000000000000000000000075012565100162016573 0ustar0000000000000000module 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)) : [] utility-ht-0.0.11/src/Test/Data/List.hs0000644000000000000000000000607412565100162015726 0ustar0000000000000000module Test.Data.List where import qualified Data.List.HT.Private as ListHT import qualified Data.List as List import Control.Monad (liftM2, ) import Test.Utility (equalLists, equalInfLists, ) import Test.QuickCheck (Testable, Property, quickCheck, (==>), ) import Prelude hiding (iterate, ) takeWhileRev :: (Ord a) => (a -> Bool) -> [a] -> Bool takeWhileRev p xs = ListHT.takeWhileRev p xs == reverse (takeWhile p (reverse xs)) dropWhileRev :: (Ord a) => (a -> Bool) -> [a] -> Bool dropWhileRev p xs = ListHT.dropWhileRev p xs == reverse (dropWhile p (reverse xs)) takeRev :: (Eq a) => Int -> [a] -> Bool takeRev n xs = ListHT.takeRev n xs == reverse (take n (reverse xs)) dropRev :: (Eq a) => Int -> [a] -> Bool dropRev n xs = ListHT.dropRev n xs == reverse (drop n (reverse xs)) sieve :: Eq a => Int -> [a] -> Property sieve n x = n>0 ==> equalLists [ListHT.sieve n x, ListHT.sieve' n x, ListHT.sieve'' n x, ListHT.sieve''' 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 sliceVertical n x = n>0 ==> ListHT.sliceVertical n x == ListHT.sliceVertical' 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) shear :: Eq a => [[a]] -> Bool shear xs = ListHT.shearTranspose xs == map reverse (ListHT.shear xs) outerProduct :: (Eq a, Eq b) => [a] -> [b] -> Bool outerProduct xs ys = concat (ListHT.outerProduct (,) xs ys) == liftM2 (,) xs ys iterate :: Eq a => (a -> a -> a) -> a -> Bool iterate op a = let xs = List.iterate (op a) a ys = ListHT.iterateAssociative op a zs = ListHT.iterateLeaky op a in equalInfLists 1000 [xs, ys, zs] mapAdjacent :: (Num a, Eq a) => a -> [a] -> Bool mapAdjacent x xs = ListHT.mapAdjacent subtract (scanl (+) x xs) == xs simple :: (Testable test) => (Int -> [Integer] -> test) -> IO () simple = quickCheck tests :: [(String, IO ())] tests = ("takeWhileRev", quickCheck (\a -> takeWhileRev ((a::Integer)>=))) : ("dropWhileRev", quickCheck (\a -> dropWhileRev ((a::Integer)>=))) : ("takeRev", simple takeRev) : ("dropRev", simple dropRev) : ("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)) : ("mapAdjacent", quickCheck (mapAdjacent :: Integer -> [Integer] -> Bool)) : [] utility-ht-0.0.11/src/Text/0000755000000000000000000000000012565100162013604 5ustar0000000000000000utility-ht-0.0.11/src/Text/Read/0000755000000000000000000000000012565100162014457 5ustar0000000000000000utility-ht-0.0.11/src/Text/Read/HT.hs0000644000000000000000000000166212565100162015333 0ustar0000000000000000module Text.Read.HT where {-| Parse a string containing an infix operator. -} {-# INLINE readsInfixPrec #-} readsInfixPrec :: (Read a, Read b) => String -> Int -> Int -> (a -> b -> c) -> ReadS c readsInfixPrec opStr opPrec prec cons = readParen (prec >= opPrec) ((\s -> [(const . cons, s)]) .> readsPrec opPrec .> (filter ((opStr==).fst) . lex) .> readsPrec opPrec) {-| Compose two parsers sequentially. -} infixl 9 .> (.>) :: ReadS (b -> c) -> ReadS b -> ReadS c (.>) ra rb = concatMap (\(f,rest) -> map (\(b, rest') -> (f b, rest')) (rb rest)) . ra readMany :: (Read a) => String -> [a] readMany x = let contReadList [] = [] contReadList (y:[]) = fst y : readMany (snd y) contReadList _ = error "readMany: ambiguous parses" in contReadList (reads x) maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of [(x,"")] -> Just x _ -> Nothing utility-ht-0.0.11/src/Text/Show/0000755000000000000000000000000012565100162014524 5ustar0000000000000000utility-ht-0.0.11/src/Text/Show/HT.hs0000644000000000000000000000073412565100162015377 0ustar0000000000000000module Text.Show.HT where {-| Show a value using an infix operator. -} {-# INLINE showsInfixPrec #-} 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 -} utility-ht-0.0.11/src/Control/0000755000000000000000000000000012565100162014300 5ustar0000000000000000utility-ht-0.0.11/src/Control/Functor/0000755000000000000000000000000012565100162015720 5ustar0000000000000000utility-ht-0.0.11/src/Control/Functor/HT.hs0000644000000000000000000000154312565100162016572 0ustar0000000000000000module Control.Functor.HT where import Data.Tuple.HT (fst3, snd3, thd3, ) void :: Functor f => f a -> f () void = fmap (const ()) map :: Functor f => (a -> b) -> f a -> f b map = fmap for :: Functor f => f a -> (a -> b) -> f b for = flip fmap {- | Caution: Every pair member has a reference to the argument of 'unzip'. Depending on the consumption pattern this may cause a memory leak. For lists, I think, you should generally prefer 'List.unzip'. -} unzip :: Functor f => f (a, b) -> (f a, f b) unzip x = (fmap fst x, fmap snd x) {- | Caution: See 'unzip'. -} unzip3 :: Functor f => f (a, b, c) -> (f a, f b, f c) unzip3 x = (fmap fst3 x, fmap snd3 x, fmap thd3 x) {- | Generalization of 'Data.List.HT.outerProduct'. -} outerProduct :: (Functor f, Functor g) => (a -> b -> c) -> f a -> g b -> f (g c) outerProduct f xs ys = fmap (flip fmap ys . f) xs utility-ht-0.0.11/src/Control/Monad/0000755000000000000000000000000012565100162015336 5ustar0000000000000000utility-ht-0.0.11/src/Control/Monad/HT.hs0000644000000000000000000000650412565100162016212 0ustar0000000000000000module Control.Monad.HT where import qualified Control.Monad as M import Prelude hiding (repeat, until, ) infixr 1 <=< {- | Also present in newer versions of the 'base' package. -} (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) (<=<) f g = (f =<<) . g {- | Monadic 'List.repeat'. -} repeat :: (Monad m) => m a -> m [a] repeat x = let go = lift2 (:) x go in go {-# DEPRECATED untilM "use M.until" #-} {- | repeat action until result fulfills condition -} until, untilM :: (Monad m) => (a -> Bool) -> m a -> m a untilM = until until p m = let go = do x <- m if p x then return x else go in go {-# DEPRECATED iterateLimitM "use M.iterateLimit" #-} {- | parameter order equal to that of 'nest' -} iterateLimit, iterateLimitM :: Monad m => Int -> (a -> m a) -> a -> m [a] iterateLimitM = iterateLimit iterateLimit m f = let aux n x = lift (x:) $ if n==0 then return [] else aux (n-1) =<< f x in aux m {- | Lazy monadic conjunction. That is, when the first action returns @False@, then @False@ is immediately returned, without running the second action. -} andLazy :: (Monad m) => m Bool -> m Bool -> m Bool andLazy m0 m1 = m0 >>= \b -> if b then m1 else return False {- | Lazy monadic disjunction. That is, when the first action returns @True@, then @True@ is immediately returned, without running the second action. -} orLazy :: (Monad m) => m Bool -> m Bool -> m Bool orLazy m0 m1 = m0 >>= \b -> if b then return True else m1 void :: (Monad m) => m a -> m () void = lift (const ()) for :: Monad m => [a] -> (a -> m b) -> m [b] for = M.forM map :: Monad m => (a -> m b) -> [a] -> m [b] map = M.mapM zipWith :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] zipWith = M.zipWithM chain :: (Monad m) => [a -> m a] -> (a -> m a) chain = foldr (flip (<=<)) return filter :: Monad m => (a -> m Bool) -> [a] -> m [a] filter = M.filterM replicate :: Monad m => Int -> m a -> m [a] replicate = M.replicateM lift :: Monad m => (a -> r) -> m a -> m r lift = M.liftM lift2 :: Monad m => (a -> b -> r) -> m a -> m b -> m r lift2 = M.liftM2 lift3 :: Monad m => (a -> b -> c -> r) -> m a -> m b -> m c -> m r lift3 = M.liftM3 lift4 :: Monad m => (a -> b -> c -> d -> r) -> m a -> m b -> m c -> m d -> m r lift4 = M.liftM4 lift5 :: Monad m => (a -> b -> c -> d -> e -> r) -> m a -> m b -> m c -> m d -> m e -> m r lift5 = M.liftM5 {- that's just (=<<) liftJoin :: (Monad m) => (a -> m b) -> m a -> m b liftJoin f ma = join (lift f ma) -} liftJoin2 :: (Monad m) => (a -> b -> m c) -> m a -> m b -> m c liftJoin2 f ma mb = M.join (lift2 f ma mb) liftJoin3 :: (Monad m) => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d liftJoin3 f ma mb mc = M.join (lift3 f ma mb mc) liftJoin4 :: (Monad m) => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e liftJoin4 f ma mb mc md = M.join (lift4 f ma mb mc md) liftJoin5 :: (Monad m) => (a -> b -> c -> d -> e -> m f) -> m a -> m b -> m c -> m d -> m e -> m f liftJoin5 f ma mb mc md me = M.join (lift5 f ma mb mc md me) {- Add functions with restricted types? Shall their element types be monoids? Should we add these functions to a Foldable.HT module in order to save the underscore? (>>) mapM_ zipWithM_ sequence_ ... -} utility-ht-0.0.11/src/Data/0000755000000000000000000000000012565100162013531 5ustar0000000000000000utility-ht-0.0.11/src/Data/Monoid/0000755000000000000000000000000012565100162014756 5ustar0000000000000000utility-ht-0.0.11/src/Data/Monoid/HT.hs0000644000000000000000000000066712565100162015636 0ustar0000000000000000module Data.Monoid.HT (cycle, (<>), when, ) where import Data.Monoid (Monoid, mappend, mempty, ) import Data.Function (fix, ) import Prelude (Bool) {- | Generalization of 'Data.List.cycle' to any monoid. -} cycle :: Monoid m => m -> m cycle x = fix (mappend x) infixr 6 <> {- | Infix synonym for 'mappend'. -} (<>) :: Monoid m => m -> m -> m (<>) = mappend when :: Monoid m => Bool -> m -> m when b m = if b then m else mempty utility-ht-0.0.11/src/Data/Eq/0000755000000000000000000000000012565100162014076 5ustar0000000000000000utility-ht-0.0.11/src/Data/Eq/HT.hs0000644000000000000000000000023712565100162014747 0ustar0000000000000000module Data.Eq.HT where import Data.Function.HT (compose2, ) {-# INLINE equating #-} equating :: Eq b => (a -> b) -> a -> a -> Bool equating = compose2 (==) utility-ht-0.0.11/src/Data/String/0000755000000000000000000000000012565100162014777 5ustar0000000000000000utility-ht-0.0.11/src/Data/String/HT.hs0000644000000000000000000000032112565100162015642 0ustar0000000000000000module Data.String.HT where import Data.Char (isSpace, ) import Data.List.HT (dropWhileRev, ) -- | remove leading and trailing spaces trim :: String -> String trim = dropWhileRev isSpace . dropWhile isSpace utility-ht-0.0.11/src/Data/Bool/0000755000000000000000000000000012565100162014424 5ustar0000000000000000utility-ht-0.0.11/src/Data/Bool/HT.hs0000644000000000000000000000021612565100162015272 0ustar0000000000000000module Data.Bool.HT ( B.if', B.ifThenElse, B.select, (B.?:), B.implies, ) where import qualified Data.Bool.HT.Private as B utility-ht-0.0.11/src/Data/Bool/HT/0000755000000000000000000000000012565100162014737 5ustar0000000000000000utility-ht-0.0.11/src/Data/Bool/HT/Private.hs0000644000000000000000000000254712565100162016715 0ustar0000000000000000module Data.Bool.HT.Private where import Data.List as List (find, ) import Data.Maybe as Maybe (fromMaybe, ) {- | @if-then-else@ as function. Example: > if' (even n) "even" $ > if' (isPrime n) "prime" $ > "boring" -} {-# INLINE if' #-} if' :: Bool -> a -> a -> a if' True x _ = x 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. Example: > select "boring" $ > (even n, "even") : > (isPrime n, "prime") : > [] -} {-# INLINE select #-} select, select0, select1 :: a -> [(Bool, a)] -> a select def = maybe def snd . find fst select0 def = fromMaybe def . lookup True select1 = foldr (uncurry if') zipIf :: [Bool] -> [a] -> [a] -> [a] zipIf = zipWith3 if' infixr 1 ?: {- | Like the @?@ operator of the C progamming language. Example: @bool ?: ("yes", "no")@. -} {-# INLINE (?:) #-} (?:) :: Bool -> (a,a) -> a (?:) = uncurry . if' -- precedence below (||) and (&&) infixr 1 `implies` {- | Logical operator for implication. Funnily because of the ordering of 'Bool' it holds @implies == (<=)@. -} {-# INLINE implies #-} implies :: Bool -> Bool -> Bool implies prerequisite conclusion = not prerequisite || conclusion utility-ht-0.0.11/src/Data/Function/0000755000000000000000000000000012565100162015316 5ustar0000000000000000utility-ht-0.0.11/src/Data/Function/HT.hs0000644000000000000000000000046612565100162016173 0ustar0000000000000000module Data.Function.HT ( nest, powerAssociative, compose2, ) where import Data.Function.HT.Private (nest, powerAssociative, ) {- | Known as @on@ in newer versions of the @base@ package. -} {-# INLINE compose2 #-} compose2 :: (b -> b -> c) -> (a -> b) -> (a -> a -> c) compose2 g f x y = g (f x) (f y) utility-ht-0.0.11/src/Data/Function/HT/0000755000000000000000000000000012565100162015631 5ustar0000000000000000utility-ht-0.0.11/src/Data/Function/HT/Private.hs0000644000000000000000000000261212565100162017600 0ustar0000000000000000module Data.Function.HT.Private where import Data.List (genericReplicate, ) {- | Compositional power of a function, i.e. apply the function @n@ times to a value. It is rather the same as @iter@ in Simon Thompson: \"The Craft of Functional Programming\", page 172 -} {-# INLINE nest #-} nest, nest1, nest2 :: Int -> (a -> a) -> a -> a nest 0 _ x = x nest n f x = f (nest (n-1) f x) nest1 n f = foldr (.) id (replicate n f) nest2 n f x = iterate f x !! n propNest :: (Eq a) => Int -> (a -> a) -> a -> Bool propNest n f x = nest n f x == nest1 n f x {- | @powerAssociative@ is an auxiliary function that, for an associative operation @op@, computes the same value as @powerAssociative op a0 a n = foldr op a0 (genericReplicate n a)@ but applies "op" O(log n) times and works for large n. -} {-# INLINE powerAssociative #-} {-# INLINE powerAssociative1 #-} powerAssociative, powerAssociative1 :: (a -> a -> a) -> a -> a -> Integer -> a powerAssociative _ a0 _ 0 = a0 powerAssociative op a0 a n = 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) infixl 0 $% {- | Flipped version of '($)'. It was discussed as (&) in http://www.haskell.org/pipermail/libraries/2012-November/018832.html I am not sure, that we need it. It is not exported for now. -} ($%) :: a -> (a -> b) -> b ($%) = flip ($) utility-ht-0.0.11/src/Data/Ord/0000755000000000000000000000000012565100162014255 5ustar0000000000000000utility-ht-0.0.11/src/Data/Ord/HT.hs0000644000000000000000000000116712565100162015131 0ustar0000000000000000module Data.Ord.HT where import Data.Function.HT (compose2, ) {-# INLINE comparing #-} comparing :: Ord b => (a -> b) -> a -> a -> Ordering comparing = compose2 compare {- | @limit (lower,upper) x@ restricts @x@ to the range from @lower@ to @upper@. Don't expect a sensible result for @lower>upper@. -} {-# INLINE limit #-} limit :: (Ord a) => (a,a) -> a -> a limit (l,u) = max l . min u {- | @limit (lower,upper) x@ checks whether @x@ is in the range from @lower@ to @upper@. Don't expect a sensible result for @lower>upper@. -} {-# INLINE inRange #-} inRange :: (Ord a) => (a,a) -> a -> Bool inRange (l,u) x = l<=x && x<=u utility-ht-0.0.11/src/Data/Strictness/0000755000000000000000000000000012565100162015672 5ustar0000000000000000utility-ht-0.0.11/src/Data/Strictness/HT.hs0000644000000000000000000000120212565100162016534 0ustar0000000000000000module Data.Strictness.HT where {-# INLINE arguments1 #-} arguments1 :: (a -> x) -> a -> x arguments1 f a = f $! a {-# INLINE arguments2 #-} arguments2 :: (a -> b -> x) -> a -> b -> x arguments2 f a b = (f $! a) $! b {-# INLINE arguments3 #-} arguments3 :: (a -> b -> c -> x) -> a -> b -> c -> x arguments3 f a b c = ((f $! a) $! b) $! c {-# INLINE arguments4 #-} arguments4 :: (a -> b -> c -> d -> x) -> a -> b -> c -> d -> x arguments4 f a b c d = (((f $! a) $! b) $! c) $! d {-# INLINE arguments5 #-} arguments5 :: (a -> b -> c -> d -> e -> x) -> a -> b -> c -> d -> e -> x arguments5 f a b c d e = ((((f $! a) $! b) $! c) $! d) $! e utility-ht-0.0.11/src/Data/Tuple/0000755000000000000000000000000012565100162014622 5ustar0000000000000000utility-ht-0.0.11/src/Data/Tuple/Lazy.hs0000644000000000000000000000326112565100162016077 0ustar0000000000000000module Data.Tuple.Lazy where -- * Pair {- | Cf. '(Control.Arrow.***)'. Apply two functions on corresponding values in a pair, where the pattern match on the pair constructor is lazy. This is crucial in recursions such as the one of 'partition'. One the other hand there are applications where strict application is crucial, e.g. @mapSnd f ab@ where the left pair member is a large lazy list. With the lazy @mapSnd@ we make the application of @f@ depend on the whole pair @ab@. See "Data.Tuple.Example" for two examples where one variant is definitely better than the other one. -} {- Instead of lazy pattern matching with \code{(x,y)} we may use \function{fst} and \function{snd}. -} {-# INLINE mapPair #-} mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) mapPair ~(f,g) ~(x,y) = (f x, g y) -- | 'Control.Arrow.first' {-# INLINE mapFst #-} mapFst :: (a -> c) -> (a,b) -> (c,b) mapFst f ~(a,b) = (f a, b) -- | 'Control.Arrow.second' {-# INLINE mapSnd #-} mapSnd :: (b -> c) -> (a,b) -> (a,c) mapSnd f ~(a,b) = (a, f b) {-# INLINE swap #-} swap :: (a,b) -> (b,a) swap ~(x,y) = (y,x) {-# INLINE forcePair #-} forcePair :: (a,b) -> (a,b) forcePair ~(x,y) = (x,y) -- * Triple {-# INLINE mapTriple #-} mapTriple :: (a -> d, b -> e, c -> f) -> (a,b,c) -> (d,e,f) mapTriple ~(f,g,h) ~(x,y,z) = (f x, g y, h z) {-# INLINE mapFst3 #-} mapFst3 :: (a -> d) -> (a,b,c) -> (d,b,c) mapFst3 f ~(a,b,c) = (f a, b, c) {-# INLINE mapSnd3 #-} mapSnd3 :: (b -> d) -> (a,b,c) -> (a,d,c) mapSnd3 f ~(a,b,c) = (a, f b, c) {-# INLINE mapThd3 #-} mapThd3 :: (c -> d) -> (a,b,c) -> (a,b,d) mapThd3 f ~(a,b,c) = (a, b, f c) {-# INLINE uncurry3 #-} uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) uncurry3 f ~(a,b,c) = f a b c utility-ht-0.0.11/src/Data/Tuple/HT.hs0000644000000000000000000000101012565100162015461 0ustar0000000000000000module Data.Tuple.HT ( -- * Pair mapPair, mapFst, mapSnd, swap, forcePair, -- * Triple fst3, snd3, thd3, mapTriple, mapFst3, mapSnd3, mapThd3, curry3, uncurry3, ) where import Data.Tuple.Lazy {-# INLINE fst3 #-} fst3 :: (a,b,c) -> a fst3 (x,_,_) = x {-# INLINE snd3 #-} snd3 :: (a,b,c) -> b snd3 (_,x,_) = x {-# INLINE thd3 #-} thd3 :: (a,b,c) -> c thd3 (_,_,x) = x {-# INLINE curry3 #-} curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d curry3 f a b c = f (a,b,c) utility-ht-0.0.11/src/Data/Tuple/Example.hs0000644000000000000000000000173212565100162016554 0ustar0000000000000000module Data.Tuple.Example where import qualified Data.Tuple.Lazy as Lazy import qualified Data.Tuple.Strict as Strict import Data.List.HT (sieve, ) partitionLazy :: (a -> Bool) -> [a] -> ([a], [a]) partitionLazy p = foldr (\x -> (if p x then Lazy.mapFst else Lazy.mapSnd) (x:)) ([], []) partitionStrict :: (a -> Bool) -> [a] -> ([a], [a]) partitionStrict p = foldr (\x -> (if p x then Strict.mapFst else Strict.mapSnd) (x:)) ([], []) mainPartitionRuns :: IO () mainPartitionRuns = print $ partitionLazy (>=0) $ repeat (0::Int) mainPartitionBlocks :: IO () mainPartitionBlocks = print $ partitionStrict (>=0) $ repeat (0::Int) printSomeChars :: (Show a) => a -> IO () printSomeChars = putStrLn . sieve 100000 . show mainMemoryOk :: IO () mainMemoryOk = printSomeChars $ Strict.mapSnd (1+) $ (iterate (1+) (0::Int), 0::Int) mainMemoryLeak :: IO () mainMemoryLeak = printSomeChars $ Lazy.mapSnd (1+) $ (iterate (1+) (0::Int), 0::Int) utility-ht-0.0.11/src/Data/Tuple/Strict.hs0000644000000000000000000000163412565100162016432 0ustar0000000000000000module Data.Tuple.Strict where -- * Pair {-# INLINE mapPair #-} mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) mapPair (f,g) (x,y) = (f x, g y) {-# INLINE mapFst #-} mapFst :: (a -> c) -> (a,b) -> (c,b) mapFst f (a,b) = (f a, b) {-# INLINE mapSnd #-} mapSnd :: (b -> c) -> (a,b) -> (a,c) mapSnd f (a,b) = (a, f b) {-# INLINE swap #-} swap :: (a,b) -> (b,a) swap (x,y) = (y,x) -- * Triple {-# INLINE mapTriple #-} mapTriple :: (a -> d, b -> e, c -> f) -> (a,b,c) -> (d,e,f) mapTriple (f,g,h) (x,y,z) = (f x, g y, h z) {-# INLINE mapFst3 #-} mapFst3 :: (a -> d) -> (a,b,c) -> (d,b,c) mapFst3 f (a,b,c) = (f a, b, c) {-# INLINE mapSnd3 #-} mapSnd3 :: (b -> d) -> (a,b,c) -> (a,d,c) mapSnd3 f (a,b,c) = (a, f b, c) {-# INLINE mapThd3 #-} mapThd3 :: (c -> d) -> (a,b,c) -> (a,b,d) mapThd3 f (a,b,c) = (a, b, f c) {-# INLINE uncurry3 #-} uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) uncurry3 f (a,b,c) = f a b c utility-ht-0.0.11/src/Data/Ix/0000755000000000000000000000000012565100162014111 5ustar0000000000000000utility-ht-0.0.11/src/Data/Ix/Enum.hs0000644000000000000000000000236612565100162015360 0ustar0000000000000000{- | Implementations of 'Ix' methods in terms of 'Enum' methods. For a type @T@ of class 'Enum' you can easily define an 'Ix' instance by copying the following code into your module: >import qualified Data.Ix.Enum as IxEnum > >instance Ix T where > range = IxEnum.range > index = IxEnum.index > inRange = IxEnum.inRange > rangeSize = IxEnum.rangeSize > unsafeIndex = IxEnum.unsafeIndex > unsafeRangeSize = IxEnum.unsafeRangeSize -} module Data.Ix.Enum where {-# INLINE range #-} {-# INLINE index #-} {-# INLINE unsafeIndex #-} {-# INLINE inRange #-} {-# INLINE rangeSize #-} {-# INLINE unsafeRangeSize #-} range :: Enum a => (a, a) -> [a] index :: Enum a => (a, a) -> a -> Int unsafeIndex :: Enum a => (a, a) -> a -> Int inRange :: Enum a => (a, a) -> a -> Bool rangeSize :: Enum a => (a, a) -> Int unsafeRangeSize :: Enum a => (a, a) -> Int range (l,r) = map toEnum $ range (fromEnum l, fromEnum r) index (l,r) i = index (fromEnum l, fromEnum r) (fromEnum i) unsafeIndex (l,r) i = unsafeIndex (fromEnum l, fromEnum r) (fromEnum i) inRange (l,r) i = inRange (fromEnum l, fromEnum r) (fromEnum i) rangeSize (l,r) = rangeSize (fromEnum l, fromEnum r) unsafeRangeSize (l,r) = unsafeRangeSize (fromEnum l, fromEnum r) utility-ht-0.0.11/src/Data/Record/0000755000000000000000000000000012565100162014747 5ustar0000000000000000utility-ht-0.0.11/src/Data/Record/HT.hs0000644000000000000000000000015312565100162015615 0ustar0000000000000000module Data.Record.HT ( R.compare, R.equal, ) where import qualified Data.Record.HT.Private as R utility-ht-0.0.11/src/Data/Record/HT/0000755000000000000000000000000012565100162015262 5ustar0000000000000000utility-ht-0.0.11/src/Data/Record/HT/Private.hs0000644000000000000000000000157212565100162017235 0ustar0000000000000000module Data.Record.HT.Private where import Data.Monoid (mconcat, ) import Data.List.HT (switchL, ) {- | Lexicographically compare a list of attributes of two records. Example: > compare [comparing fst, comparing snd] -} {-# INLINE compare #-} compare :: [a -> a -> Ordering] -> a -> a -> Ordering compare cs x y = mconcat $ map (\c -> c x y) cs {-# INLINE compare1 #-} compare1 :: [a -> a -> Ordering] -> a -> a -> Ordering compare1 cs x y = switchL EQ const $ dropWhile (EQ==) $ map (\c -> c x y) cs {-# INLINE compare2 #-} compare2 :: [a -> a -> Ordering] -> a -> a -> Ordering compare2 cs x y = head $ dropWhile (EQ==) (map (\c -> c x y) cs) ++ [EQ] {- | Check whether a selected set of fields of two records is equal. Example: > equal [equating fst, equating snd] -} {-# INLINE equal #-} equal :: [a -> a -> Bool] -> a -> a -> Bool equal cs x y = all (\c -> c x y) cs utility-ht-0.0.11/src/Data/Maybe/0000755000000000000000000000000012565100162014566 5ustar0000000000000000utility-ht-0.0.11/src/Data/Maybe/HT.hs0000644000000000000000000000177412565100162015446 0ustar0000000000000000module Data.Maybe.HT where 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 toMaybe False _ = Nothing toMaybe True x = Just x infixl 6 ?-> {- | This is an infix version of 'fmap' for writing 'Data.Bool.HT.select' style expressions using test functions, that produce 'Maybe's. The precedence is chosen to be higher than '(:)', in order to allow: > alternatives default $ > checkForA ?-> (\a -> f a) : > checkForB ?-> (\b -> g b) : > [] The operation is left associative in order to allow to write > checkForA ?-> f ?-> g which is equivalent to > checkForA ?-> g . f due to the functor law. -} (?->) :: Maybe a -> (a -> b) -> Maybe b (?->) = flip fmap alternatives :: a -> [Maybe a] -> a alternatives deflt = fromMaybe deflt . msum utility-ht-0.0.11/src/Data/List/0000755000000000000000000000000012565100162014444 5ustar0000000000000000utility-ht-0.0.11/src/Data/List/Match.hs0000644000000000000000000000036312565100162016036 0ustar0000000000000000module Data.List.Match ( L.take, L.drop, L.splitAt, L.takeRev, L.dropRev, L.replicate, L.equalLength, L.compareLength, L.lessOrEqualLength, L.shorterList, ) where import qualified Data.List.Match.Private as L utility-ht-0.0.11/src/Data/List/Key.hs0000644000000000000000000000104112565100162015524 0ustar0000000000000000{- | Variant of "Data.List" functions like 'Data.List.group', 'Data.List.sort' where the comparison is performed on a key computed from the list elements. In principle these functions could be replaced by e.g. @sortBy (compare `on` f)@, but @f@ will be re-computed for every comparison. If the evaluation of @f@ is expensive, our functions are better, since they buffer the results of @f@. -} module Data.List.Key ( L.nub, L.sort, L.minimum, L.maximum, L.group, L.merge, ) where import qualified Data.List.Key.Private as L utility-ht-0.0.11/src/Data/List/HT.hs0000644000000000000000000000227012565100162015314 0ustar0000000000000000module Data.List.HT ( -- * Improved standard functions L.inits, L.tails, L.groupBy, L.group, L.unzip, L.partition, L.span, L.break, -- * Split L.chop, L.breakAfter, L.segmentAfter, L.segmentBefore, L.segmentAfterMaybe, L.segmentBeforeMaybe, L.removeEach, L.splitEverywhere, -- * inspect ends of a list L.splitLast, L.viewL, L.viewR, L.switchL, L.switchR, -- * List processing starting at the end L.dropRev, L.takeRev, L.dropWhileRev, L.takeWhileRev, -- * List processing with Maybe and Either L.maybePrefixOf, L.partitionMaybe, L.takeWhileJust, L.unzipEithers, -- * Sieve and slice L.sieve, L.sliceHorizontal, L.sliceVertical, -- * Search&replace L.search, L.replace, L.multiReplace, -- * Lists of lists L.shear, L.shearTranspose, L.outerProduct, -- * Miscellaneous L.takeWhileMulti, L.rotate, L.mergeBy, L.allEqual, L.isAscending, L.isAscendingLazy, L.mapAdjacent, L.mapAdjacent1, L.range, L.padLeft, L.padRight, L.iterateAssociative, L.iterateLeaky, L.lengthAtLeast, ) where import qualified Data.List.HT.Private as L utility-ht-0.0.11/src/Data/List/Key/0000755000000000000000000000000012565100162015174 5ustar0000000000000000utility-ht-0.0.11/src/Data/List/Key/Private.hs0000644000000000000000000000534612565100162017152 0ustar0000000000000000module Data.List.Key.Private where import Data.Function.HT (compose2, ) import Data.List (nubBy, sortBy, minimumBy, maximumBy, ) import Prelude hiding (minimum, maximum, ) attach :: (a -> b) -> [a] -> [(b,a)] attach key = map (\x -> (key x, x)) aux :: (((key, a) -> (key, a) -> b) -> [(key, a)] -> c) -> (key -> key -> b) -> (a -> key) -> ([a] -> c) aux listFunc cmpFunc key = listFunc (compose2 cmpFunc fst) . attach key aux' :: ((a -> a -> b) -> [a] -> c) -> (key -> key -> b) -> (a -> key) -> ([a] -> c) aux' listFunc cmpFunc key = listFunc (compose2 cmpFunc key) {- | Divides a list into sublists such that the members in a sublist share the same key. It uses semantics of 'Data.List.HT.groupBy', not that of 'Data.List.groupBy'. -} group :: Eq b => (a -> b) -> [a] -> [[a]] group key = map (map snd) . aux groupBy (==) key {- | Will be less efficient than 'group' if @key@ is computationally expensive. This is so because the key is re-evaluated for each list item. Alternatively you may write @groupBy ((==) `on` key)@. -} group' :: Eq b => (a -> b) -> [a] -> [[a]] group' = aux' groupBy (==) propGroup :: (Eq a, Eq b) => (a -> b) -> [a] -> Bool propGroup key xs = group key xs == group' key xs {- | argmin -} minimum :: Ord b => (a -> b) -> [a] -> a minimum key = snd . aux minimumBy compare key {- | argmax -} maximum :: Ord b => (a -> b) -> [a] -> a maximum key = snd . aux maximumBy compare key sort :: Ord b => (a -> b) -> [a] -> [a] sort key = map snd . aux sortBy compare key merge :: Ord b => (a -> b) -> [a] -> [a] -> [a] merge key xs ys = map snd $ mergeBy (compose2 (<=) fst) (attach key xs) (attach key ys) nub :: Eq b => (a -> b) -> [a] -> [a] nub key = map snd . aux nubBy (==) key -- * helper functions groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy p = map (uncurry (:)) . groupByNonEmpty p groupByNonEmpty :: (a -> a -> Bool) -> [a] -> [(a,[a])] groupByNonEmpty p = foldr (\x0 yt -> let (xr,yr) = case yt of (x1,xs):ys -> if p x0 x1 then (x1:xs,ys) else ([],yt) [] -> ([],yt) in (x0,xr):yr) [] groupByEmpty :: (a -> a -> Bool) -> [a] -> [[a]] groupByEmpty p = uncurry (:) . foldr (\x0 ~(y,ys) -> if (case y of x1:_ -> p x0 x1; _ -> True) then (x0:y,ys) else (x0:[],y:ys)) ([],[]) mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] mergeBy p = let recourse [] yl = yl recourse xl [] = xl recourse xl@(x:xs) yl@(y:ys) = uncurry (:) $ if p x y then (x, recourse xs yl) else (y, recourse xl ys) in recourse utility-ht-0.0.11/src/Data/List/Match/0000755000000000000000000000000012565100162015500 5ustar0000000000000000utility-ht-0.0.11/src/Data/List/Match/Private.hs0000644000000000000000000000747712565100162017465 0ustar0000000000000000module Data.List.Match.Private where import Data.Maybe (fromJust, isNothing, ) import Data.Maybe.HT (toMaybe, ) import Data.Tuple.HT (mapFst, forcePair, ) import Data.Bool.HT (if', ) import qualified Data.List as List import Control.Functor.HT (void, ) import Prelude hiding (take, drop, splitAt, replicate, ) {- | Make a list as long as another one -} {- @flip (zipWith const)@ is not as lazy, e.g. would be @take [] undefined = undefined@, but it should be @take [] undefined = []@. -} take :: [b] -> [a] -> [a] take = zipWith (flip const) {- | Drop as many elements as the first list is long -} drop :: [b] -> [a] -> [a] 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)) drop1 :: [b] -> [a] -> [a] drop1 xs ys = map snd (dropWhile (not . null . fst) (zip (iterate laxTail xs) ys)) drop2 :: [b] -> [a] -> [a] drop2 xs ys = snd $ head $ dropWhile (not . null . fst) $ zip (iterate laxTail xs) (iterate laxTail ys) {- | @laxTail [] = []@ -} laxTail :: [a] -> [a] laxTail xt = case xt of [] -> []; _:xs -> xs laxTail0 :: [a] -> [a] laxTail0 = List.drop 1 splitAt :: [b] -> [a] -> ([a],[a]) splitAt nt xt = forcePair $ case (nt,xt) of (_:ns, x:xs) -> mapFst (x:) $ splitAt ns xs (_, xs) -> ([],xs) takeRev :: [b] -> [a] -> [a] takeRev ys xs = drop (drop ys xs) xs dropRev :: [b] -> [a] -> [a] dropRev ys xs = take (drop ys xs) xs {- | Check whether two lists with different element types have equal length. It is equivalent to @length xs == length ys@ but more efficient. -} equalLength :: [a] -> [b] -> Bool equalLength xs ys = void xs == void ys {- | Compare the length of two lists over different types. It is equivalent to @(compare (length xs) (length ys))@ but more efficient. -} compareLength :: [a] -> [b] -> Ordering compareLength xs ys = compare (void xs) (void ys) {- | this one uses explicit recursion -} compareLength0 :: [a] -> [b] -> Ordering compareLength0 = let recourse (_:xs) (_:ys) = recourse xs ys recourse [] [] = EQ recourse (_:_) [] = GT recourse [] (_:_) = LT in recourse {- | strict comparison -} compareLength1 :: [a] -> [b] -> Ordering compareLength1 xs ys = compare (length xs) (length ys) {- | @lessOrEqualLength x y@ is almost the same as @compareLength x y <= EQ@, but @lessOrEqualLength [] undefined = True@, whereas @compareLength [] undefined <= EQ = undefined@. -} lessOrEqualLength :: [a] -> [b] -> Bool lessOrEqualLength [] _ = True lessOrEqualLength _ [] = False lessOrEqualLength (_:xs) (_:ys) = lessOrEqualLength xs ys {- | Returns the shorter one of two lists. It works also for infinite lists as much as possible. E.g. @shorterList (shorterList (repeat 1) (repeat 2)) [1,2,3]@ can be computed. The trick is, that the skeleton of the resulting list is constructed using 'zipWith' without touching the elements. The contents is then computed (only) if requested. -} shorterList :: [a] -> [a] -> [a] shorterList xs ys = let useX = lessOrEqualLength xs ys in zipWith (if' useX) xs ys {- | This is lazier than 'shorterList' in a different aspect: It returns a common prefix even if it is undefined, which list is the shorter one. However, it requires a proper 'Eq' instance and if elements are undefined, it may fail even earlier. -} shorterListEq :: (Eq a) => [a] -> [a] -> [a] shorterListEq xs ys = let useX = lessOrEqualLength xs ys in zipWith (\x y -> if' (x==y || useX) x y) xs ys {- | Specialisation of 'Data.Functor.$>'. -} replicate :: [a] -> b -> [b] replicate xs y = take xs (repeat y) utility-ht-0.0.11/src/Data/List/HT/0000755000000000000000000000000012565100162014757 5ustar0000000000000000utility-ht-0.0.11/src/Data/List/HT/Private.hs0000644000000000000000000006503512565100162016736 0ustar0000000000000000module Data.List.HT.Private where import Data.List as List (find, transpose, unfoldr, isPrefixOf, findIndices, foldl', mapAccumL, ) import Data.Maybe as Maybe (fromMaybe, catMaybes, ) import Data.Maybe.HT (toMaybe, ) import Control.Monad (guard, msum, ) import Data.Tuple.HT (mapPair, mapFst, mapSnd, forcePair, swap, ) import qualified Data.List.Key.Private as Key import qualified Data.List.Match.Private as Match import Prelude hiding (unzip, break, span, ) -- * Improved standard functions {- | This function is lazier than the one suggested in the Haskell 98 report. It is @inits undefined = [] : undefined@, in contrast to @Data.List.inits undefined = undefined@. -} {- suggested in -} inits :: [a] -> [[a]] inits = map reverse . scanl (flip (:)) [] {- | As lazy as 'inits' but less efficient because of repeated 'map'. -} initsLazy :: [a] -> [[a]] initsLazy xt = [] : case xt of [] -> [] x:xs -> map (x:) (initsLazy xs) {- | Suggested implementation in the Haskell 98 report. It is not as lazy as possible. -} inits98 :: [a] -> [[a]] inits98 [] = [[]] inits98 (x:xs) = [[]] ++ map (x:) (inits98 xs) inits98' :: [a] -> [[a]] inits98' = foldr (\x prefixes -> [] : map (x:) prefixes) [[]] {- | This function is lazier than the one suggested in the Haskell 98 report. It is @tails undefined = ([] : undefined) : undefined@, in contrast to @Data.List.tails undefined = undefined@. -} tails :: [a] -> [[a]] tails xt = uncurry (:) $ case xt of [] -> ([],[]) _:xs -> (xt, tails xs) tails' :: [a] -> [[a]] tails' = fst . breakAfter null . iterate tail tails98 :: [a] -> [[a]] tails98 [] = [[]] tails98 xxs@(_:xs) = xxs : tails98 xs {- | This function compares adjacent elements of a list. If two adjacent elements satisfy a relation then they are put into the same sublist. Example: > groupBy (<) "abcdebcdef" == ["abcde","bcdef"] In contrast to that 'Data.List.groupBy' compares the head of each sublist with each candidate for this sublist. This yields > List.groupBy (<) "abcdebcdef" == ["abcdebcdef"] The second @'b'@ is compared with the leading @'a'@. Thus it is put into the same sublist as @'a'@. The sublists are never empty. Thus the more precise result type would be @[(a,[a])]@. -} groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy = Key.groupBy group :: (Eq a) => [a] -> [[a]] group = groupBy (==) {- | Like standard 'unzip' but more lazy. It is @Data.List.unzip undefined == undefined@, but @unzip undefined == (undefined, undefined)@. -} unzip :: [(a,b)] -> ([a],[b]) unzip = forcePair . foldr (\ (x,y) ~(xs,ys) -> (x:xs,y:ys)) ([],[]) {- | 'Data.List.partition' of GHC 6.2.1 fails on infinite lists. But this one does not. -} {- The lazy pattern match @(y,z)@ is necessary since otherwise it fails on infinite lists. -} partition :: (a -> Bool) -> [a] -> ([a], [a]) partition p = forcePair . foldr (\x ~(y,z) -> if p x then (x : y, z) else (y, x : z)) ([],[]) {- | It is @Data.List.span f undefined = undefined@, whereas @span f undefined = (undefined, undefined)@. -} span, break :: (a -> Bool) -> [a] -> ([a],[a]) span p = let recourse xt = forcePair $ fromMaybe ([],xt) $ do (x,xs) <- viewL xt guard $ p x return $ mapFst (x:) $ recourse xs in recourse break p = span (not . p) -- * Split {- | Split the list at the occurrences of a separator into sub-lists. Remove the separators. 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 = uncurry (:) . foldr (\ x ~(y,ys) -> if p x then ([],y:ys) else ((x:y),ys) ) ([],[]) chop' :: (a -> Bool) -> [a] -> [[a]] chop' p = let recourse = uncurry (:) . mapSnd (switchL [] (const recourse)) . break p in recourse chopAtRun :: (Eq a) => (a -> Bool) -> [a] -> [[a]] chopAtRun p = let recourse [] = [[]] recourse y = let (z,zs) = break p (dropWhile p y) in z : recourse zs in recourse {- | Like 'break', but splits after the matching element. -} breakAfter :: (a -> Bool) -> [a] -> ([a], [a]) breakAfter p = let recourse [] = ([],[]) recourse (x:xs) = mapFst (x:) $ if p x then ([],xs) else recourse xs in forcePair . recourse {- | Split the list after each occurence of a terminator. Keep the terminator. There is always a list for the part after the last terminator. It may be empty. See package @non-empty@ for more precise result type. -} segmentAfter :: (a -> Bool) -> [a] -> [[a]] segmentAfter p = uncurry (:) . foldr (\x ~(y,ys) -> mapFst (x:) $ if p x then ([],y:ys) else (y,ys)) ([],[]) segmentAfter' :: (a -> Bool) -> [a] -> [[a]] segmentAfter' p = foldr (\ x ~yt@(y:ys) -> if p x then [x]:yt else (x:y):ys) [[]] propSegmentAfterConcat :: Eq a => (a -> Bool) -> [a] -> Bool propSegmentAfterConcat p xs = concat (segmentAfter p xs) == xs propSegmentAfterNumSeps :: (a -> Bool) -> [a] -> Bool propSegmentAfterNumSeps p xs = length (filter p xs) == length (tail (segmentAfter p xs)) propSegmentAfterLasts :: (a -> Bool) -> [a] -> Bool propSegmentAfterLasts p = all (p . last) . init . segmentAfter p propSegmentAfterInits :: (a -> Bool) -> [a] -> Bool propSegmentAfterInits p = all (all (not . p) . init) . init . segmentAfter p {- This test captures both infinitely many groups and infinitely big groups. -} propSegmentAfterInfinite :: (a -> Bool) -> a -> [a] -> Bool propSegmentAfterInfinite p x = flip seq True . (!!100) . concat . segmentAfter p . cycle . (x:) {- | Split the list before each occurence of a leading character. Keep these characters. There is always a list for the part before the first leading character. It may be empty. See package @non-empty@ for more precise result type. -} segmentBefore :: (a -> Bool) -> [a] -> [[a]] segmentBefore p = -- foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]] uncurry (:) . foldr (\ x ~(y,ys) -> let xs = x:y in if p x then ([],xs:ys) else (xs,ys)) ([],[]) segmentBefore' :: (a -> Bool) -> [a] -> [[a]] segmentBefore' p = uncurry (:) . (\xst -> fromMaybe ([],xst) $ do ((x:xs):xss) <- Just xst guard $ not $ p x return (x:xs, xss)) . groupBy (\_ x -> not $ p x) segmentBefore'' :: (a -> Bool) -> [a] -> [[a]] segmentBefore'' p = (\xst -> case xst of ~(xs:xss) -> tail xs : xss) . groupBy (\_ x -> not $ p x) . (error "segmentBefore: dummy element" :) propSegmentBeforeConcat :: Eq a => (a -> Bool) -> [a] -> Bool propSegmentBeforeConcat p xs = concat (segmentBefore p xs) == xs propSegmentBeforeNumSeps :: (a -> Bool) -> [a] -> Bool propSegmentBeforeNumSeps p xs = length (filter p xs) == length (tail (segmentBefore p xs)) propSegmentBeforeHeads :: (a -> Bool) -> [a] -> Bool propSegmentBeforeHeads p = all (p . head) . tail . segmentBefore p propSegmentBeforeTails :: (a -> Bool) -> [a] -> Bool propSegmentBeforeTails p = all (all (not . p) . tail) . tail . segmentBefore p propSegmentBeforeInfinite :: (a -> Bool) -> a -> [a] -> Bool propSegmentBeforeInfinite p x = flip seq True . (!!100) . concat . segmentBefore p . cycle . (x:) propSegmentBeforeGroupBy0 :: Eq a => (a -> Bool) -> [a] -> Bool propSegmentBeforeGroupBy0 p xs = segmentBefore p xs == segmentBefore' p xs propSegmentBeforeGroupBy1 :: Eq a => (a -> Bool) -> [a] -> Bool propSegmentBeforeGroupBy1 p xs = segmentBefore p xs == segmentBefore'' p xs {- | > Data.List.HT Data.Char> segmentBeforeMaybe (\c -> toMaybe (isLetter c) (toUpper c)) "123a5345b---" > ("123",[('A',"5345"),('B',"---")]) -} segmentBeforeMaybe :: (a -> Maybe b) -> [a] -> ([a], [(b, [a])]) segmentBeforeMaybe f = forcePair . foldr (\ x ~(y,ys) -> case f x of Just b -> ([],(b,y):ys) Nothing -> (x:y,ys)) ([],[]) {- | > Data.List.HT Data.Char> segmentAfterMaybe (\c -> toMaybe (isLetter c) (toUpper c)) "123a5345b---" > ([("123",'A'),("5345",'B')],"---") -} segmentAfterMaybe :: (a -> Maybe b) -> [a] -> ([([a], b)], [a]) segmentAfterMaybe f = swap . uncurry (mapAccumL (\as0 (b,as1) -> (as1, (as0,b)))) . segmentBeforeMaybe f -- cf. Matroid.hs {- | @removeEach xs@ represents a list of sublists of @xs@, where each element of @xs@ is removed and the removed element is separated. It seems to be much simpler to achieve with @zip xs (map (flip List.delete xs) xs)@, but the implementation of 'removeEach' does not need the 'Eq' instance and thus can also be used for lists of functions. See also the proposal -} removeEach :: [a] -> [(a, [a])] removeEach = map (\(ys, pivot, zs) -> (pivot,ys++zs)) . splitEverywhere splitEverywhere :: [a] -> [([a], a, [a])] splitEverywhere xs = map (\(y, zs0) -> case zs0 of z:zs -> (y,z,zs) [] -> error "splitEverywhere: empty list") (init (zip (inits xs) (tails xs))) -- * inspect ends of a list {-# DEPRECATED splitLast "use viewR instead" #-} {- | It holds @splitLast xs == (init xs, last xs)@, but 'splitLast' is more efficient if the last element is accessed after the initial ones, because it avoids memoizing list. -} splitLast :: [a] -> ([a], a) splitLast [] = error "splitLast: empty list" splitLast [x] = ([], x) splitLast (x:xs) = let (xs', lastx) = splitLast xs in (x:xs', lastx) propSplitLast :: Eq a => [a] -> Bool propSplitLast xs = splitLast xs == (init xs, last xs) {- | Should be prefered to 'head' and 'tail'. -} {-# INLINE viewL #-} viewL :: [a] -> Maybe (a, [a]) viewL (x:xs) = Just (x,xs) viewL [] = Nothing {- | Should be prefered to 'init' and 'last'. -} viewR :: [a] -> Maybe ([a], a) viewR = foldr (\x -> Just . forcePair . maybe ([],x) (mapFst (x:))) Nothing propViewR :: Eq a => [a] -> Bool propViewR xs = maybe True ((init xs, last xs) == ) (viewR xs) {- | Should be prefered to 'head' and 'tail'. -} {-# INLINE switchL #-} switchL :: b -> (a -> [a] -> b) -> [a] -> b switchL n _ [] = n switchL _ j (x:xs) = j x xs switchL' :: b -> (a -> [a] -> b) -> [a] -> b switchL' n j = maybe n (uncurry j) . viewL {- | Should be prefered to 'init' and 'last'. -} {-# INLINE switchR #-} switchR :: b -> ([a] -> a -> b) -> [a] -> b switchR n j = maybe n (uncurry j) . viewR propSwitchR :: Eq a => [a] -> Bool propSwitchR xs = switchR True (\ixs lxs -> ixs == init xs && lxs == last xs) xs -- * List processing starting at the end {- | @takeRev n@ is like @reverse . take n . reverse@ but it is lazy enough to work for infinite lists, too. -} takeRev :: Int -> [a] -> [a] takeRev n xs = Match.drop (drop n xs) xs {- | @dropRev n@ is like @reverse . drop n . reverse@ but it is lazy enough to work for infinite lists, too. -} dropRev :: Int -> [a] -> [a] dropRev n xs = Match.take (drop n xs) xs {- | Remove the longest suffix of elements satisfying p. In contrast to @reverse . dropWhile p . reverse@ this works for infinite lists, too. -} dropWhileRev :: (a -> Bool) -> [a] -> [a] dropWhileRev p = foldr (\x xs -> if p x && null xs then [] else x:xs) [] dropWhileRev' :: (a -> Bool) -> [a] -> [a] dropWhileRev' p = concat . init . segmentAfter (not . p) {- | Alternative version of @reverse . takeWhile p . reverse@. -} takeWhileRev :: (a -> Bool) -> [a] -> [a] takeWhileRev p = last . segmentAfter (not . p) {- | Doesn't seem to be superior to the naive implementation. -} takeWhileRev' :: (a -> Bool) -> [a] -> [a] takeWhileRev' p = (\xs -> if fst (head xs) then map snd xs else []) . last . Key.aux groupBy (==) p {- | However it is more inefficient, because of repeatedly appending single elements. :-( -} takeWhileRev'' :: (a -> Bool) -> [a] -> [a] takeWhileRev'' p = foldl (\xs x -> if p x then xs++[x] else []) [] -- * List processing with Maybe and Either {- | @maybePrefixOf xs ys@ is @Just zs@ if @xs@ is a prefix of @ys@, where @zs@ is @ys@ without the prefix @xs@. Otherwise it is @Nothing@. -} maybePrefixOf :: Eq a => [a] -> [a] -> Maybe [a] maybePrefixOf (x:xs) (y:ys) = guard (x==y) >> maybePrefixOf xs ys maybePrefixOf [] ys = Just ys maybePrefixOf _ [] = Nothing {- | Partition a list into elements which evaluate to @Just@ or @Nothing@ by @f@. It holds @mapMaybe f == fst . partitionMaybe f@ and @partition p == partitionMaybe (\ x -> toMaybe (p x) x)@. -} partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) partitionMaybe f = forcePair . foldr (\x -> maybe (mapSnd (x:)) (\y -> mapFst (y:)) (f x)) ([],[]) {- | This is the cousin of 'takeWhile' analogously to 'catMaybes' being the cousin of 'filter'. Example: Keep the heads of sublists until an empty list occurs. > takeWhileJust $ map (fmap fst . viewL) xs -} takeWhileJust :: [Maybe a] -> [a] takeWhileJust = foldr (\x acc -> maybe [] (:acc) x) [] unzipEithers :: [Either a b] -> ([a], [b]) unzipEithers = forcePair . foldr (either (\x -> mapFst (x:)) (\y -> mapSnd (y:))) ([],[]) -- * Sieve and slice {-| keep every k-th value from the list -} sieve, sieve', sieve'', sieve''' :: Int -> [a] -> [a] sieve k = unfoldr (\xs -> toMaybe (not (null xs)) (head xs, drop k xs)) sieve' k = map head . sliceVertical k sieve'' k x = map (x!!) [0,k..(length x-1)] sieve''' k = map head . takeWhile (not . null) . iterate (drop k) propSieve :: Eq a => Int -> [a] -> Bool propSieve n x = sieve n x == sieve' n x && sieve n x == sieve'' n x {- sliceHorizontal is faster than sliceHorizontal' but consumes slightly more memory (although it needs no swapping) -} sliceHorizontal, sliceHorizontal', sliceHorizontal'', sliceHorizontal''' :: Int -> [a] -> [[a]] sliceHorizontal n = map (sieve n) . take n . iterate (drop 1) sliceHorizontal' n = foldr (\x ys -> let y = last ys in Match.take ys ((x:y):ys)) (replicate n []) sliceHorizontal'' n = reverse . foldr (\x ~(y:ys) -> ys ++ [x:y]) (replicate n []) sliceHorizontal''' n = take n . transpose . takeWhile (not . null) . iterate (drop n) propSliceHorizontal :: Eq a => Int -> [a] -> Bool propSliceHorizontal n x = sliceHorizontal n x == sliceHorizontal' n x && sliceHorizontal n x == sliceHorizontal'' n x && sliceHorizontal n x == sliceHorizontal''' n x sliceVertical, sliceVertical' :: Int -> [a] -> [[a]] sliceVertical n = map (take n) . takeWhile (not . null) . iterate (drop n) {- takeWhile must be performed before (map take) in order to handle (n==0) correctly -} sliceVertical' n = unfoldr (\x -> toMaybe (not (null x)) (splitAt n x)) propSliceVertical :: Eq a => Int -> [a] -> Bool propSliceVertical n x = take 100000 (sliceVertical n x) == take 100000 (sliceVertical' n x) propSlice :: Eq a => Int -> [a] -> Bool propSlice n x = -- problems: sliceHorizontal 4 [] == [[],[],[],[]] sliceHorizontal n x == transpose (sliceVertical n x) && sliceVertical n x == transpose (sliceHorizontal n x) -- * Search&replace 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') = foldr (\c ~(hd, rest) -> let xs = c:hd in case maybePrefixOf sub xs of Just suffix -> ([], Nothing : Just suffix : rest) Nothing -> (xs, rest)) ([],[]) ys in Just hd' : rest' replace' :: (Eq a) => [a] -> [a] -> [a] -> [a] replace' src dst xs = concatMap (fromMaybe dst) (markSublists src xs) propReplaceId :: (Eq a) => [a] -> [a] -> Bool propReplaceId xs ys = replace xs xs ys == ys propReplaceCycle :: (Eq a) => [a] -> [a] -> Bool propReplaceCycle xs ys = replace xs ys (cycle xs) == cycle ys {- | This is slightly wrong, because it re-replaces things. 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 = foldr (\x xs -> let y=x:xs in if isPrefixOf src y then dst ++ drop (length src) y else y) [] multiReplace :: Eq a => [([a], [a])] -> [a] -> [a] 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)) (find (flip isPrefixOf str . fst) dict) in recourse propMultiReplaceSingle :: Eq a => [a] -> [a] -> [a] -> Bool propMultiReplaceSingle src dst x = replace src dst x == multiReplace [(src,dst)] x -- * Lists of lists {- | Transform > [[00,01,02,...], [[00], > [10,11,12,...], --> [10,01], > [20,21,22,...], [20,11,02], > ...] ...] With @concat . shear@ you can perform a Cantor diagonalization, that is an enumeration of all elements of the sub-lists where each element is reachable within a finite number of steps. It is also useful for polynomial multiplication (convolution). -} shear :: [[a]] -> [[a]] shear = map catMaybes . shearTranspose . transposeFill transposeFill :: [[a]] -> [[Maybe a]] transposeFill = unfoldr (\xs -> toMaybe (not (null xs)) (mapSnd (dropWhileRev null) $ unzipCons xs)) unzipCons :: [[a]] -> ([Maybe a], [[a]]) unzipCons = unzip . map ((\my -> (fmap fst my, maybe [] snd my)) . viewL) {- | It's somehow inverse to zipCons, but the difficult part is, that a trailing empty list on the right side is suppressed. -} unzipConsSkew :: [[a]] -> ([Maybe a], [[a]]) unzipConsSkew = let aux [] [] = ([],[]) -- one empty list at the end will be removed aux xs ys = mapSnd (xs:) $ prep ys prep = forcePair . switchL ([],[]) (\y ys -> let my = viewL y in mapFst (fmap fst my :) $ aux (maybe [] snd my) ys) in prep shear' :: [[a]] -> [[a]] shear' xs@(_:_) = let (y:ys,zs) = unzip (map (splitAt 1) xs) zipConc (a:as) (b:bs) = (a++b) : zipConc as bs zipConc [] bs = bs zipConc as [] = as in y : zipConc ys (shear' (dropWhileRev null zs)) {- Dropping trailing empty lists is necessary, otherwise finite lists are filled with empty lists. -} shear' [] = [] {- | Transform > [[00,01,02,...], [[00], > [10,11,12,...], --> [01,10], > [20,21,22,...], [02,11,20], > ...] ...] It's like 'shear' but the order of elements in the sub list is reversed. Its implementation seems to be more efficient than that of 'shear'. If the order does not matter, better choose 'shearTranspose'. -} shearTranspose :: [[a]] -> [[a]] shearTranspose = foldr zipConsSkew [] zipConsSkew :: [a] -> [[a]] -> [[a]] zipConsSkew xt yss = uncurry (:) $ case xt of x:xs -> ([x], zipCons xs yss) [] -> ([], yss) {- | zipCons is like @zipWith (:)@ but it keeps lists which are too long This version works also for @zipCons something undefined@. -} zipCons :: [a] -> [[a]] -> [[a]] zipCons (x:xs) yt = let (y,ys) = switchL ([],[]) (,) yt in (x:y) : zipCons xs ys zipCons [] ys = ys -- | zipCons' is like @zipWith (:)@ but it keeps lists which are too long zipCons' :: [a] -> [[a]] -> [[a]] zipCons' (x:xs) (y:ys) = (x:y) : zipCons' xs ys zipCons' [] ys = ys zipCons' xs [] = map (:[]) xs {- | Operate on each combination of elements of the first and the second list. In contrast to the list instance of 'Monad.liftM2' in holds the results in a list of lists. It holds @concat (outerProduct f xs ys) == liftM2 f xs ys@ -} outerProduct :: (a -> b -> c) -> [a] -> [b] -> [[c]] outerProduct f xs ys = map (flip map ys . f) xs -- * Miscellaneous {- | Take while first predicate holds, then continue taking while second predicate holds, and so on. -} takeWhileMulti :: [a -> Bool] -> [a] -> [a] takeWhileMulti [] _ = [] takeWhileMulti _ [] = [] takeWhileMulti aps@(p:ps) axs@(x:xs) = if p x then x : takeWhileMulti aps xs else takeWhileMulti ps axs takeWhileMulti' :: [a -> Bool] -> [a] -> [a] takeWhileMulti' ps xs = concatMap fst (tail (scanl (flip span . snd) (undefined,xs) ps)) propTakeWhileMulti :: (Eq a) => [a -> Bool] -> [a] -> Bool propTakeWhileMulti ps xs = takeWhileMulti ps xs == takeWhileMulti' ps xs {- Debug.QuickCheck.quickCheck (propTakeWhileMulti [(<0), (>0), odd, even, ((0::Int)==)]) -} {- | This is a combination of 'foldl'' and 'foldr' in the sense of 'propFoldl'r'. It is however more efficient because it avoids storing the whole input list as a result of sharing. -} foldl'r, foldl'rStrict, foldl'rNaive :: (b -> a -> b) -> b -> (c -> d -> d) -> d -> [(a,c)] -> (b,d) foldl'r f b0 g d0 = -- (\(k,d1) -> (k b0, d1)) . mapFst ($b0) . foldr (\(a,c) ~(k,d) -> (\b -> k $! f b a, g c d)) (id,d0) foldl'rStrict f b0 g d0 = mapFst ($b0) . foldr (\(a,c) ~(k,d) -> ((,) $! (\b -> k $! f b a)) $! g c d) (id,d0) foldl'rNaive f b g d xs = mapPair (foldl' f b, foldr g d) $ unzip xs propFoldl'r :: (Eq b, Eq d) => (b -> a -> b) -> b -> (c -> d -> d) -> d -> [(a,c)] -> Bool propFoldl'r f b g d xs = foldl'r f b g d xs == foldl'rNaive f b g d xs {- The results in GHCi surprise: *List.HT> mapSnd last $ foldl'rNaive (+) (0::Integer) (:) "" $ replicate 1000000 (1,'a') (1000000,'a') (0.44 secs, 141032856 bytes) *List.HT> mapSnd last $ foldl'r (+) (0::Integer) (:) "" $ replicate 1000000 (1,'a') (1000000,'a') (2.64 secs, 237424948 bytes) -} {- Debug.QuickCheck.quickCheck (\b d -> propFoldl'r (+) (b::Int) (++) (d::[Int])) -} lengthAtLeast :: Int -> [a] -> Bool lengthAtLeast n = if n<=0 then const False else not . null . drop (n-1) {- 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 -} rotate, rotate', rotate'' :: Int -> [a] -> [a] rotate n x = Match.take x (drop (mod n (length x)) (cycle x)) {- | more efficient implementation of rotate' -} rotate' n x = uncurry (flip (++)) (splitAt (mod n (length x)) x) rotate'' n x = Match.take x (drop n (cycle x)) propRotate :: Eq a => Int -> [a] -> Bool propRotate n x = rotate n x == rotate' n x && rotate n x == rotate'' n x {- Debug.QuickCheck.quickCheck (\n x -> n>=0 Debug.QuickCheck.==> List.HT.propRotate n ((0::Int):x)) -} {-| Given two lists that are ordered (i.e. @p x y@ holds for subsequent @x@ and @y@) 'mergeBy' them into a list that is ordered, again. -} mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] mergeBy = Key.mergeBy allEqual :: Eq a => [a] -> Bool allEqual = and . mapAdjacent (==) isAscending :: (Ord a) => [a] -> Bool isAscending = and . isAscendingLazy isAscendingLazy :: (Ord a) => [a] -> [Bool] isAscendingLazy = mapAdjacent (<=) {- | This function combines every pair of neighbour elements in a list with a certain function. -} mapAdjacent :: (a -> a -> b) -> [a] -> [b] mapAdjacent f xs = zipWith f xs (tail xs) {- | > mapAdjacent f a0 [(a1,b1), (a2,b2), (a3,b3)] > == > [f a0 a1 b1, f a1 a2 b2, f a2 a3 b3] -} mapAdjacent1 :: (a -> a -> b -> c) -> a -> [(a,b)] -> [c] mapAdjacent1 f a xs = zipWith (\a0 (a1,b) -> f a0 a1 b) (a : map fst xs) xs {- | Enumerate without Enum context. For Enum equivalent to enumFrom. -} range :: Num a => Int -> [a] range n = take n (iterate (+1) 0) {-# INLINE padLeft #-} padLeft :: a -> Int -> [a] -> [a] padLeft c n xs = replicate (n - length xs) c ++ xs {-# INLINE padRight #-} padRight, padRight1 :: a -> Int -> [a] -> [a] padRight c n xs = take n $ xs ++ repeat c padRight1 c n xs = xs ++ replicate (n - length xs) c {- | For an associative operation @op@ this computes @iterateAssociative op a = iterate (op a) a@ but it is even faster than @map (powerAssociative op a a) [0..]@ since it shares temporary results. The idea is: From the list @map (powerAssociative op a a) [0,(2*n)..]@ we compute the list @map (powerAssociative op a a) [0,n..]@, and iterate that until @n==1@. -} iterateAssociative :: (a -> a -> a) -> a -> [a] iterateAssociative op a = foldr (\pow xs -> pow : concatMap (\x -> [x, op x pow]) xs) undefined (iterate (\x -> op x x) a) {- | This is equal to 'iterateAssociative'. The idea is the following: The list we search is the fixpoint of the function: "Square all elements of the list, then spread it and fill the holes with successive numbers of their left neighbour." This also preserves log n applications per value. However it has a space leak, because for the value with index @n@ all elements starting at @div n 2@ must be kept. -} iterateLeaky :: (a -> a -> a) -> a -> [a] iterateLeaky op x = let merge (a:as) b = a : merge b as merge _ _ = error "iterateLeaky: an empty list cannot occur" sqrs = map (\y -> op y y) z z = x : merge sqrs (map (op x) sqrs) in z