diff --git a/ListLike.cabal b/ListLike.cabal --- a/ListLike.cabal +++ b/ListLike.cabal @@ -1,5 +1,5 @@ Name: ListLike -Version: 4.6.2 +Version: 4.6.3 License: BSD3 Maintainer: David Fox Author: John Goerzen @@ -9,7 +9,7 @@ Category: list, string, text, bytestring, vector Cabal-Version: >= 1.8 Build-Type: Simple -homepage: http://github.com/JohnLato/listlike +homepage: http://github.com/ddssff/listlike synopsis: Generalized support for list-like structures Description: Generalized support for list-like structures in Haskell. . @@ -22,10 +22,10 @@ ByteString, for types that support input and output, and for types that can handle infinite lists. Stability: Stable -Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 +Tested-With: GHC == 8.8.1, GHC == 8.6.5, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.2 Library - GHC-Options: -O2 + GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Data.ListLike Data.ListLike.Base diff --git a/src/Data/ListLike.hs b/src/Data/ListLike.hs --- a/src/Data/ListLike.hs +++ b/src/Data/ListLike.hs @@ -23,12 +23,12 @@ Please start with the introduction at "Data.ListLike#intro". -} -module Data.ListLike +module Data.ListLike (-- * Introduction -- $intro - + -- * Creation & Basic Functions - empty, singleton, + empty, singleton, cons, snoc, append, uncons, head, last, tail, init, null, length, -- * List transformations map, rigidMap, reverse, intersperse, @@ -52,7 +52,7 @@ -- * Sublists -- ** Extracting sublists take, drop, splitAt, takeWhile, dropWhile, dropWhileEnd, span, break, - group, inits, tails, + group, inits, tails, -- ** Predicates isPrefixOf, isSuffixOf, isInfixOf, -- ** Modify based on predicate @@ -112,10 +112,10 @@ InfiniteListLike ) where -import Prelude hiding (length, head, last, null, tail, map, filter, concat, +import Prelude hiding (length, head, last, null, tail, map, filter, concat, any, lookup, init, all, foldl, foldr, foldl1, foldr1, maximum, minimum, iterate, span, break, takeWhile, - dropWhile, dropWhileEnd, reverse, zip, zipWith, sequence, + dropWhile, {-dropWhileEnd,-} reverse, zip, zipWith, sequence, sequence_, mapM, mapM_, concatMap, and, or, sum, product, repeat, replicate, cycle, take, drop, splitAt, elem, notElem, unzip, lines, words, @@ -124,9 +124,9 @@ import Data.ListLike.Chars import Data.ListLike.CharString import Data.ListLike.FoldableLL -import Data.ListLike.Instances() -import Data.ListLike.DList -import Data.ListLike.FMList +import Data.ListLike.Instances () +import Data.ListLike.DList () +import Data.ListLike.FMList () import Data.ListLike.String import Data.ListLike.Utils import Data.ListLike.IO @@ -163,7 +163,7 @@ In most cases, functions here can act as drop-in replacements for their list-specific counterparts. They will use the same underlying implementations for lists, so there should be no performance difference. - + You can make your own types instances of 'ListLike' as well. For more details, see the notes for the 'ListLike' typeclass. -} @@ -226,7 +226,7 @@ * 'map' uses the 'ListLike' implementation. 'rigidMap' is more efficient. The same goes for 'concatMap' vs. 'rigidConcatMap'. -* 'isInfixOf', 'sequence', 'mapM' and similar monad operations, 'insert', +* 'isInfixOf', 'sequence', 'mapM' and similar monad operations, 'insert', 'union', 'intersect', 'sortBy', and similar functions are not implemented in 'ByteStream' and use a naive default implementation. diff --git a/src/Data/ListLike/Base.hs b/src/Data/ListLike/Base.hs --- a/src/Data/ListLike/Base.hs +++ b/src/Data/ListLike/Base.hs @@ -35,10 +35,10 @@ InfiniteListLike(..), zip, zipWith, sequence_ ) where -import Prelude hiding (length, uncons, head, last, null, tail, map, filter, concat, +import Prelude hiding (length, {-uncons,-} head, last, null, tail, map, filter, concat, any, lookup, init, all, foldl, foldr, foldl1, foldr1, maximum, minimum, iterate, span, break, takeWhile, - dropWhile, dropWhileEnd, reverse, zip, zipWith, sequence, + dropWhile, {-dropWhileEnd,-} reverse, zip, zipWith, sequence, sequence_, mapM, mapM_, concatMap, and, or, sum, product, repeat, replicate, cycle, take, drop, splitAt, elem, notElem, unzip, lines, words, @@ -165,7 +165,7 @@ ------------------------------ Special folds {- | Flatten the structure. -} - concat :: (ListLike full' full, Monoid full) => full' -> full + concat :: (ListLike full' full{-, Monoid full-}) => full' -> full concat = fold {- | Map a function over the items and concatenate the results. @@ -443,14 +443,21 @@ ------------------------------ Generalized functions {- | Generic version of 'nub' -} + -- This code is adapted from Data.List in base. nubBy :: (item -> item -> Bool) -> full -> full - nubBy f l = nubBy' l (empty :: full) - where - nubBy' ys xs - | null ys = empty - | any (f (head ys)) xs = nubBy' (tail ys) xs - | otherwise = let y = head ys - in cons y (nubBy' (tail ys) (cons y xs)) + nubBy eq l = nubBy' l mempty + where + nubBy' ys xs = + case uncons ys of + Nothing -> mempty + Just (y, ys') + | elem_by y xs -> nubBy' ys' xs + | otherwise -> cons y (nubBy' ys' (cons y xs)) + elem_by :: item -> full -> Bool + elem_by y xs = + case uncons xs of + Nothing -> False + Just (x, xs') -> x `eq` y || elem_by y xs' {- nubBy f l | null l = empty diff --git a/src/Data/ListLike/CharString.hs b/src/Data/ListLike/CharString.hs --- a/src/Data/ListLike/CharString.hs +++ b/src/Data/ListLike/CharString.hs @@ -42,7 +42,7 @@ product, repeat, replicate, cycle, take, drop, splitAt, elem, notElem, unzip, lines, words, unlines, unwords) -import qualified Data.Foldable as F +--import qualified Data.Foldable as F import Data.ListLike.Base import Data.ListLike.String import Data.ListLike.IO @@ -52,8 +52,8 @@ import Data.Semigroup (Semigroup(..)) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified System.IO as IO -import Data.Word +--import qualified System.IO as IO +--import Data.Word import Control.Arrow -------------------------------------------------- diff --git a/src/Data/ListLike/Chars.hs b/src/Data/ListLike/Chars.hs --- a/src/Data/ListLike/Chars.hs +++ b/src/Data/ListLike/Chars.hs @@ -12,18 +12,18 @@ import Data.Monoid #endif import Control.DeepSeq -import Control.Monad +--import Control.Monad import Data.String as String (IsString(fromString)) import Data.Semigroup (Semigroup(..)) import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as TI +--import qualified Data.Text.Lazy.IO as TI import qualified Data.Text.Lazy.Builder as Builder -import Data.Text.Encoding (decodeUtf8) +--import Data.Text.Encoding (decodeUtf8) import Data.ListLike.Base as LL import Data.ListLike.FoldableLL as LL import Data.ListLike.IO import Data.ListLike.String as LL -import Data.ListLike.Text +import Data.ListLike.Text () data Chars = B Builder.Builder diff --git a/src/Data/ListLike/DList.hs b/src/Data/ListLike/DList.hs --- a/src/Data/ListLike/DList.hs +++ b/src/Data/ListLike/DList.hs @@ -1,21 +1,22 @@ {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} -- | 'Data.ListLike.ListLike' instances for 'Data.DList.DList' module Data.ListLike.DList () where -import qualified Prelude as P +--import qualified Prelude as P import Data.ListLike.Base import Data.ListLike.FoldableLL -import Data.ListLike.IO +--import Data.ListLike.IO import Data.ListLike.String import Data.DList (DList(..)) import qualified Data.DList as D -import Data.Foldable (Foldable) +--import Data.Foldable (Foldable) import qualified Data.Foldable as F -import Data.Traversable (Traversable) -import qualified Data.Traversable as T -import Data.String (IsString) +--import Data.Traversable (Traversable) +--import qualified Data.Traversable as T +--import Data.String (IsString) import qualified Data.String as S import Control.Category -import Data.Char (Char(..)) +import Data.Char (Char) instance FoldableLL (DList a) a where foldl = F.foldl diff --git a/src/Data/ListLike/FMList.hs b/src/Data/ListLike/FMList.hs --- a/src/Data/ListLike/FMList.hs +++ b/src/Data/ListLike/FMList.hs @@ -1,23 +1,24 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} -- | 'Data.ListLike.ListLike' instances for 'Data.FMList.FMList' module Data.ListLike.FMList () where -import qualified Prelude as P +import Prelude hiding (cycle, map) import Data.ListLike.Base import Data.ListLike.FoldableLL -import Data.ListLike.IO +--import Data.ListLike.IO import Data.ListLike.String import Data.FMList (FMList(..)) import qualified Data.FMList as FM -import Data.Foldable (Foldable) +--import Data.Foldable (Foldable) import qualified Data.Foldable as F -import Data.Traversable (Traversable) -import qualified Data.Traversable as T +--import Data.Traversable (Traversable) +--import qualified Data.Traversable as T import Data.String (IsString) import qualified Data.String as S import Control.Monad.Zip (MonadZip) import qualified Control.Monad.Zip as Z -import Data.Function -import Data.Char (Char(..)) +--import Data.Function +import Data.Char (Char) instance FoldableLL (FMList a) a where foldl = F.foldl diff --git a/src/Data/ListLike/FoldableLL.hs b/src/Data/ListLike/FoldableLL.hs --- a/src/Data/ListLike/FoldableLL.hs +++ b/src/Data/ListLike/FoldableLL.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + ,MultiParamTypeClasses ,FunctionalDependencies ,FlexibleInstances #-} diff --git a/src/Data/ListLike/Instances.hs b/src/Data/ListLike/Instances.hs --- a/src/Data/ListLike/Instances.hs +++ b/src/Data/ListLike/Instances.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + ,MultiParamTypeClasses ,FlexibleInstances ,TypeSynonymInstances #-} - +{-# OPTIONS -fno-warn-orphans #-} {- Copyright (C) 2007 John Goerzen @@ -37,6 +38,7 @@ splitAt, elem, notElem, unzip, lines, words, unlines, unwords) import qualified Prelude as P +import Control.Applicative ((<$>), (<*>)) import Control.Monad import qualified Data.List as L import qualified Data.Sequence as S @@ -47,22 +49,22 @@ import Data.ListLike.IO import Data.ListLike.FoldableLL import Data.ListLike.Text () -import Data.ListLike.UTF8 +import Data.ListLike.UTF8 () import Data.ListLike.Vector () import Data.Int -import Data.Maybe (fromMaybe) +--import Data.Maybe (fromMaybe) import Data.Monoid import Data.Semigroup (Semigroup(..)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC -import qualified Data.Foldable as F -import qualified Data.Traversable as T +--import qualified Data.Foldable as F +--import qualified Data.Traversable as T import qualified Data.Array.IArray as A import Data.Array.IArray((!), (//), Ix(..)) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.String.UTF8 (UTF8) -import qualified Data.String.UTF8 as UTF8 +--import Data.String.UTF8 (UTF8) +--import qualified Data.String.UTF8 as UTF8 import qualified System.IO as IO import Data.Word @@ -75,8 +77,10 @@ instance ListLikeIO String Char where hGetLine = IO.hGetLine hGetContents = IO.hGetContents - hGet h c = BSL.hGet h c >>= (return . toString) - hGetNonBlocking h i = BSL.hGetNonBlocking h i >>= (return . toString) + hGet _ c | c <= 0 = return mempty + hGet h c = cons <$> IO.hGetChar h <*> hGet h (pred c) + -- hGetNonBlocking h i >>= (return . toString) + hGetNonBlocking _h _i = error "Unimplemented: hGetNonBlocking in instance ListLikeIO String Char" hPutStr = IO.hPutStr hPutStrLn = IO.hPutStrLn getLine = IO.getLine @@ -87,6 +91,24 @@ readFile = IO.readFile writeFile = IO.writeFile +{- +import Data.ByteString.Internal (createAndTrim) +import qualified System.IO.Error as IO + +hGetNonBlocking :: IO.Handle -> Int -> IO BS.ByteString +hGetNonBlocking h i + | i > 0 = createAndTrim i $ \p -> IO.hGetBufNonBlocking h p i + | i == 0 = return empty + | otherwise = illegalBufferSize h "hGetNonBlocking'" i + +illegalBufferSize :: IO.Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioError (IO.mkIOError IO.illegalOperationErrorType msg (Just handle) Nothing) + --TODO: System.IO uses InvalidArgument here, but it's not exported :-( + where + msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] +-} + instance StringLike String where toString = id fromString = id @@ -199,9 +221,18 @@ writeFile = BS.writeFile appendFile = BS.appendFile +-- There is no bijection between Strings and ByteStrings that I know +-- of. The elements of a String are Unicode code points, and while +-- every String can be UTF8-encoded into a ByteString, there are +-- ByteStrings that can not be decoded into valid Strings - notably +-- "\128". So should ByteString be an instance of StringLike? +-- Probably not. Unfortunately, this instance is used to implement +-- the ListLikeIO instance for String! This must not stand. +#if 0 instance StringLike BS.ByteString where - toString = map (toEnum . fromIntegral) . BS.unpack - fromString = BS.pack . map (fromIntegral . fromEnum) + toString = BSU.toString + fromString = BSU.fromString +#endif -------------------------------------------------- -- ByteString.Lazy @@ -315,9 +346,11 @@ writeFile = BSL.writeFile appendFile = BSL.appendFile +#if 0 instance StringLike BSL.ByteString where - toString = map (toEnum . fromIntegral) . BSL.unpack - fromString = BSL.pack . map (fromIntegral . fromEnum) + toString = BSLU.toString + fromString = BSLU.fromString +#endif -------------------------------------------------- -- Map @@ -332,7 +365,8 @@ -------------------------------------------------- -- Arrays -instance (Ix i) => FoldableLL (A.Array i e) e where +-- This constraint is required for ghc < 8 +instance Ix i => FoldableLL (A.Array i e) e where foldl = F.foldl foldl1 = F.foldl1 foldl' = F.foldl' diff --git a/src/Data/ListLike/Text.hs b/src/Data/ListLike/Text.hs --- a/src/Data/ListLike/Text.hs +++ b/src/Data/ListLike/Text.hs @@ -1,10 +1,7 @@ -module Data.ListLike.Text ( - module Data.ListLike.Text.Text - ,module Data.ListLike.Text.TextLazy -) +module Data.ListLike.Text () where -import Data.ListLike.Text.Builder -import Data.ListLike.Text.Text -import Data.ListLike.Text.TextLazy +import Data.ListLike.Text.Builder () +import Data.ListLike.Text.Text () +import Data.ListLike.Text.TextLazy () diff --git a/src/Data/ListLike/Text/Builder.hs b/src/Data/ListLike/Text/Builder.hs --- a/src/Data/ListLike/Text/Builder.hs +++ b/src/Data/ListLike/Text/Builder.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP ,MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Text.Builder @@ -16,7 +17,7 @@ import Data.ListLike.IO import Data.ListLike.String as LL import Data.ListLike.Text.TextLazy () -import Data.String (IsString(fromString)) +--import Data.String (IsString(fromString)) instance FoldableLL Builder.Builder Char where foldl f r0 = LL.foldl f r0 . Builder.toLazyText diff --git a/src/Data/ListLike/Text/Text.hs b/src/Data/ListLike/Text/Text.hs --- a/src/Data/ListLike/Text/Text.hs +++ b/src/Data/ListLike/Text/Text.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Text.Text diff --git a/src/Data/ListLike/Text/TextLazy.hs b/src/Data/ListLike/Text/TextLazy.hs --- a/src/Data/ListLike/Text/TextLazy.hs +++ b/src/Data/ListLike/Text/TextLazy.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Text.TextLazy diff --git a/src/Data/ListLike/UTF8.hs b/src/Data/ListLike/UTF8.hs --- a/src/Data/ListLike/UTF8.hs +++ b/src/Data/ListLike/UTF8.hs @@ -4,6 +4,7 @@ ,TypeFamilies ,TypeSynonymInstances ,UndecidableInstances #-} +{-# OPTIONS -fno-warn-orphans #-} {- | Instances of 'Data.ListLike.ListLike' and related classes. @@ -22,7 +23,7 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC -import Control.DeepSeq (NFData(rnf)) +--import Control.DeepSeq (NFData(rnf)) import Data.ListLike.Base import Data.ListLike.FoldableLL import Data.ListLike.IO @@ -30,13 +31,15 @@ import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(fromString)) -import Data.String.UTF8 (UTF8, UTF8Bytes) +--import Data.String (IsString(fromString)) +import Data.String.UTF8 (UTF8{-, UTF8Bytes-}) import qualified Data.String.UTF8 as UTF8 -import GHC.Generics +--import GHC.Generics +#if 0 utf8rnf :: NFData a => UTF8 a -> () utf8rnf = rnf . UTF8.toRep +#endif instance FoldableLL (UTF8 BS.ByteString) Char where foldl = UTF8.foldl diff --git a/src/Data/ListLike/Utils.hs b/src/Data/ListLike/Utils.hs --- a/src/Data/ListLike/Utils.hs +++ b/src/Data/ListLike/Utils.hs @@ -29,7 +29,7 @@ (and, or, sum, product, zip, zipWith, unzip, sequence_, toMonadPlus, list, intercalate ) where -import Prelude hiding (length, head, last, null, tail, map, filter, concat, +import Prelude hiding (length, head, last, null, tail, map, filter, concat, any, lookup, init, all, foldl, foldr, foldl1, foldr1, maximum, minimum, iterate, span, break, takeWhile, dropWhile, reverse, zip, zipWith, sequence, diff --git a/src/Data/ListLike/Vector.hs b/src/Data/ListLike/Vector.hs --- a/src/Data/ListLike/Vector.hs +++ b/src/Data/ListLike/Vector.hs @@ -2,14 +2,10 @@ -- The @Data.ListLike.Vector.Generic@ instances are not exported from this -- module in order to prevent collisions. -- -module Data.ListLike.Vector ( - module Data.ListLike.Vector.Storable - ,module Data.ListLike.Vector.Unboxed - ,module Data.ListLike.Vector.Vector -) +module Data.ListLike.Vector () where -import Data.ListLike.Vector.Storable -import Data.ListLike.Vector.Unboxed -import Data.ListLike.Vector.Vector +import Data.ListLike.Vector.Storable () +import Data.ListLike.Vector.Unboxed () +import Data.ListLike.Vector.Vector () diff --git a/src/Data/ListLike/Vector/Generic.hs b/src/Data/ListLike/Vector/Generic.hs --- a/src/Data/ListLike/Vector/Generic.hs +++ b/src/Data/ListLike/Vector/Generic.hs @@ -6,6 +6,7 @@ #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif +{-# OPTIONS -fno-warn-orphans #-} -- | ListLike instance for any type supporting the @Data.Vector.Generic@ -- interface. To avoid collisions with other Vector instances, this module @@ -92,12 +93,14 @@ unwords = let sp = V.singleton ' ' in V.concat . intersperse sp . toList unlines = let eol = V.singleton '\n' in V.concat . intersperse eol . toList +isPrefixOf' :: (V.Vector v a, Eq (v a)) => v a -> v a -> Bool isPrefixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = needle == V.slice 0 (V.length needle) haystack | V.length needle == V.length haystack = needle == haystack | otherwise = False +isSuffixOf' :: (V.Vector v a, Eq (v a)) => v a -> v a -> Bool isSuffixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = diff --git a/src/Data/ListLike/Vector/Storable.hs b/src/Data/ListLike/Vector/Storable.hs --- a/src/Data/ListLike/Vector/Storable.hs +++ b/src/Data/ListLike/Vector/Storable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Vector.Storable () @@ -85,12 +86,14 @@ unwords = let sp = V.singleton ' ' in V.concat . intersperse sp . toList unlines = let eol = V.singleton '\n' in V.concat . intersperse eol . toList +isPrefixOf' :: (Storable a, Eq a) => V.Vector a -> V.Vector a -> Bool isPrefixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = needle == V.slice 0 (V.length needle) haystack | V.length needle == V.length haystack = needle == haystack | otherwise = False +isSuffixOf' :: (Storable a, Eq a) => V.Vector a -> V.Vector a -> Bool isSuffixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = diff --git a/src/Data/ListLike/Vector/Unboxed.hs b/src/Data/ListLike/Vector/Unboxed.hs --- a/src/Data/ListLike/Vector/Unboxed.hs +++ b/src/Data/ListLike/Vector/Unboxed.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Vector.Unboxed () @@ -84,12 +85,14 @@ unwords = let sp = V.singleton ' ' in V.concat . intersperse sp . toList unlines = let eol = V.singleton '\n' in V.concat . intersperse eol . toList +isPrefixOf' :: (Unbox a, Eq a) => V.Vector a -> V.Vector a -> Bool isPrefixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = needle == V.slice 0 (V.length needle) haystack | V.length needle == V.length haystack = needle == haystack | otherwise = False +isSuffixOf' :: (Unbox a, Eq a) => V.Vector a -> V.Vector a -> Bool isSuffixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = diff --git a/src/Data/ListLike/Vector/Vector.hs b/src/Data/ListLike/Vector/Vector.hs --- a/src/Data/ListLike/Vector/Vector.hs +++ b/src/Data/ListLike/Vector/Vector.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.ListLike.Vector.Vector () @@ -83,12 +84,14 @@ unwords = let sp = V.singleton ' ' in V.concat . intersperse sp . toList unlines = let eol = V.singleton '\n' in V.concat . intersperse eol . toList +isPrefixOf' :: Eq a => V.Vector a -> V.Vector a -> Bool isPrefixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = needle == V.slice 0 (V.length needle) haystack | V.length needle == V.length haystack = needle == haystack | otherwise = False +isSuffixOf' :: Eq a => V.Vector a -> V.Vector a -> Bool isSuffixOf' needle haystack | V.null needle = True | V.length needle < V.length haystack = diff --git a/testsrc/TestInfrastructure.hs b/testsrc/TestInfrastructure.hs --- a/testsrc/TestInfrastructure.hs +++ b/testsrc/TestInfrastructure.hs @@ -7,6 +7,7 @@ ,FlexibleInstances ,UndecidableInstances ,FlexibleContexts #-} +{-# OPTIONS -fno-warn-orphans #-} {- Copyright (C) 2007 John Goerzen @@ -21,7 +22,7 @@ module TestInfrastructure where import Test.QuickCheck -import Test.QuickCheck.Test +--import Test.QuickCheck.Test import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ListLike as LL @@ -31,7 +32,7 @@ import qualified Data.FMList as FM import qualified Data.Semigroup as Sem import qualified Data.Sequence as S -import qualified Data.Foldable as F +--import qualified Data.Foldable as F import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB @@ -39,14 +40,14 @@ import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU -import System.Random +--import System.Random import System.IO import qualified Test.HUnit as HU import Text.Printf import Data.Function (on) import Data.Word import Data.List -import Data.Monoid +import Data.Monoid (Monoid(..)) simpleArb :: (LL.ListLike f i, Arbitrary i) => Gen f simpleArb = sized (\n -> choose (0, n) >>= myVector) @@ -282,23 +283,25 @@ toString (MyList x) = x fromString x = MyList x -mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheck test) +mkTest :: Testable prop => String -> prop -> HU.Test +mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheckResult test >>= HU.assertBool msg . isSuccess) -- Modified from HUnit runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st) -runVerbTestText (HU.PutText put us) t = do - (counts, us') <- HU.performTest reportStart reportError reportFailure us t +runVerbTestText (HU.PutText put us) test = do + (counts, us') <- HU.performTest reportStart reportError reportFailure us test us'' <- put (HU.showCounts counts) True us' return (counts, us'') where - reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss)) - put (HU.showCounts (HU.counts ss)) False us + reportStart ss us' = do + hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss)) + put (HU.showCounts (HU.counts ss)) False us' reportError = reportProblem "Error:" "Error in: " reportFailure = reportProblem "Failure:" "Failure in: " #if MIN_VERSION_HUnit(1,3,0) - reportProblem p0 p1 _mloc msg ss us = put line True us + reportProblem p0 p1 _mloc msg ss us' = put line True us' #else - reportProblem p0 p1 msg ss us = put line True us + reportProblem p0 p1 msg ss us' = put line True us' #endif where line = "### " ++ kind ++ path' ++ '\n' : msg kind = if null path' then p0 else p1 @@ -316,8 +319,7 @@ forall t. Testable t => LLWrap (f' -> t) w :: TestLL f i => String -> LLTest f i -> HU.Test -w msg f = case f of - LLTest theTest -> mkTest msg theTest +w msg (LLTest theTest) = mkTest msg theTest ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test ws = w @@ -341,7 +343,7 @@ ] -- | all props, 1 args: full -apf :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, CoArbitrary f, CoArbitrary i) => LLTest f i) -> HU.Test +apf :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, CoArbitrary f, CoArbitrary i) => LLTest f i) -> HU.Test apf msg x = HU.TestLabel msg $ HU.TestList $ [w "[Int]" (x::LLTest [Int] Int), w "MyList Int" (x::LLTest (MyList Int) Int), @@ -373,15 +375,15 @@ ] -- | all props, 1 args: full -aps :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test +aps :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test aps msg x = HU.TestLabel msg $ HU.TestList $ [w "String" (x::LLTest String Char), w "MyList Char" (x::LLTest (MyList Char) Char), w "Sequence Char" (x::LLTest (S.Seq Char) Char), w "DList Char" (x::LLTest (DL.DList Char) Char), -- w "FMList Char" (x::LLTest (FM.FMList Char) Char), - w "ByteString" (x::LLTest BS.ByteString Word8), - w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8), + -- w "ByteString" (x::LLTest BS.ByteString Word8), + -- w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8), w "Chars" (x::LLTest Chars.Chars Char), w "Array Int Char" (x::LLTest (A.Array Int Char) Char), w "Text" (x::LLTest T.Text Char), diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs --- a/testsrc/runtests.hs +++ b/testsrc/runtests.hs @@ -7,6 +7,7 @@ ,FlexibleInstances ,UndecidableInstances ,FlexibleContexts #-} +{-# OPTIONS -fno-warn-missing-signatures #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AllowAmbiguousTypes #-} @@ -22,19 +23,20 @@ -} module Main where -import Control.Applicative +import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck import qualified Data.ListLike as LL -import qualified Data.Foldable as F -import System.Random +--import qualified Data.Foldable as F +--import System.Random import qualified Test.HUnit as HU import System.IO -import Text.Printf -import Data.Word +--import Text.Printf +--import Data.Word import Data.List import Data.Monoid import TestInfrastructure import Data.Foldable(foldr', fold, foldMap) +import System.Exit import System.Info @@ -45,8 +47,8 @@ prop_empty f = (LL.toList l == []) && (LL.null l) && (LL.length l == 0) where l = asTypeOf LL.empty f -prop_tofromlist f = - LL.toList f == l && +prop_tofromlist f = + LL.toList f == l && LL.length f == length l && f == (LL.fromList . LL.toList $ f) where l = LL.toList f @@ -70,7 +72,7 @@ prop_reverse f = llcmp (LL.reverse f) (reverse (LL.toList f)) prop_intersperse f i = llcmp (LL.intersperse i f) (intersperse i (LL.toList f)) -prop_concat f = +prop_concat f = llcmp (LL.concat f) (concat $ map LL.toList (LL.toList f)) prop_concatmap :: forall full item. (TestLL full item, TestLL [item] item) => full -> (item -> [item]) -> Property @@ -91,18 +93,18 @@ prop_take f count = llcmp (LL.take count f) (take count (LL.toList f)) prop_drop f count = count >= 0 ==> llcmp (LL.drop count f) (drop count (LL.toList f)) prop_splitAt f count = count >= 0 ==> - llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.splitAt count $ f] + llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.splitAt count $ f] [LL.splitAt count (LL.toList f)] -prop_takeWhile f func = llcmp (LL.takeWhile func f) +prop_takeWhile f func = llcmp (LL.takeWhile func f) (takeWhile func (LL.toList f)) -prop_dropWhile f func = llcmp (LL.dropWhile func f) +prop_dropWhile f func = llcmp (LL.dropWhile func f) (dropWhile func (LL.toList f)) prop_dropWhileEnd f func = llcmp (LL.dropWhileEnd func f) (dropWhileEnd func (LL.toList f)) -prop_span f func = +prop_span f func = llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.span func $ f] [span func (LL.toList f)] -prop_break f func = +prop_break f func = llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.break func $ f] [break func (LL.toList f)] prop_group f = @@ -110,7 +112,7 @@ (map LL.toList (LL.group f)) == (group (LL.toList f)) prop_inits f = (map LL.toList (LL.inits f)) == (inits (LL.toList f)) prop_tails f = (map LL.toList (LL.tails f)) == (tails (LL.toList f)) -prop_isPrefixOf f1 f2 = LL.isPrefixOf f1 f2 == +prop_isPrefixOf f1 f2 = LL.isPrefixOf f1 f2 == (isPrefixOf (LL.toList f1) (LL.toList f2)) prop_isSuffixOf f1 f2 = LL.isSuffixOf f1 f2 == (isSuffixOf (LL.toList f1) (LL.toList f2)) @@ -125,7 +127,7 @@ prop_notElem f i = LL.notElem i f == notElem i (LL.toList f) prop_find f func = LL.find func f == find func (LL.toList f) prop_filter f func = llcmp (LL.filter func f) (filter func (LL.toList f)) -prop_partition f func = +prop_partition f func = (LL.toList f1, LL.toList f2) == partition func (LL.toList f) where (f1, f2) = LL.partition func f prop_index f i = (i >= 0 && i < LL.length f) ==> @@ -148,7 +150,7 @@ where llmapM = asTypeOf (LL.mapM func f) (Just (LL.toList f)) prop_rigidMapM :: forall full item. (TestLL full item, TestLL [item] item) => full -> (item -> Maybe item) -> Property -prop_rigidMapM f func = +prop_rigidMapM f func = case (LL.rigidMapM func f, mapM func (LL.toList f)) of (Just ll, Just l) -> llcmp ll l (Nothing, Nothing) -> property True @@ -158,16 +160,16 @@ prop_nub f = llcmp (LL.nub f) (nub (LL.toList f)) prop_delete f i = llcmp (LL.delete i f) (delete i (LL.toList f)) -prop_deleteFirsts f1 f2 = llcmp (LL.deleteFirsts f1 f2) +prop_deleteFirsts f1 f2 = llcmp (LL.deleteFirsts f1 f2) ((LL.toList f1) \\ (LL.toList f2)) -prop_union f1 f2 = llcmp (LL.union f1 f2) +prop_union f1 f2 = llcmp (LL.union f1 f2) (union (LL.toList f1) (LL.toList f2)) -prop_intersect f1 f2 = llcmp (LL.intersect f1 f2) +prop_intersect f1 f2 = llcmp (LL.intersect f1 f2) (intersect (LL.toList f1) (LL.toList f2)) prop_sort f1 = llcmp (LL.sort f1) (sort (LL.toList f1)) prop_insert f i = llcmp (LL.insert i f) (insert i (LL.toList f)) prop_nubBy f func = llcmp (LL.nubBy func f) (nubBy func (LL.toList f)) -prop_deleteBy f func i = llcmp (LL.deleteBy func i f) +prop_deleteBy f func i = llcmp (LL.deleteBy func i f) (deleteBy func i (LL.toList f)) prop_deleteFirstsBy f1 f2 func = llcmp (LL.deleteFirstsBy func f1 f2) (deleteFirstsBy func (LL.toList f1) (LL.toList f2)) @@ -203,12 +205,12 @@ -- full -> Result prop_zip f = LL.zip f f2 == zip (LL.toList f) f2 where f2 = [(-5::Int)..] -prop_zipWith f = +prop_zipWith f = LL.toList res == (zipWith func (LL.toList f) f2) where f2 = [(100::Int)..(-100)] func x y = (y + 5, x) res = asTypeOf (LL.zipWith func f f2) [(5::Int, LL.head f)] ---FIXME: prop_unzip +--FIXME: prop_unzip --FIXME: prop_and --FIXME: prop_or --FIXME: prop_sum @@ -216,7 +218,7 @@ prop_foldl f func (i::Int) = LL.foldl func i f == foldl func i (LL.toList f) prop_foldl' f func (i::Integer) = LL.foldl' func i f == foldl' func i (LL.toList f) -prop_foldl1 f func = not (LL.null f) ==> +prop_foldl1 f func = not (LL.null f) ==> (LL.foldl1 func f) == (foldl1 func (LL.toList f)) prop_foldr f func (i::Int) = LL.foldr func i f == foldr func i (LL.toList f) prop_foldr' f func (i::Integer) = @@ -234,7 +236,7 @@ prop_toString f = ((LL.fromString . LL.toString $ f) == f) where l = LL.toList f -prop_fromString f x = +prop_fromString f x = LL.toString (asTypeOf (LL.fromString x) f) == x prop_lines f = map LL.toString res == lines (LL.toString f) where res = asTypeOf (LL.lines f) [f] @@ -323,13 +325,13 @@ apf "genericSplitAt" (t prop_genericSplitAt), apf "genericReplicate" (t prop_genericReplicate), apf "zip" (t prop_zip), - apf "zipWith" (t prop_zipWith) + apf "zipWith" (t prop_zipWith) -- apf "unzip" (t prop_unzip), -- apf "and" (t prop_and), -- apf "or" (t prop_or), -- apf "sum" (t prop_sum), -- apf "propduct" (t prop_product), - -- sequence_ + -- sequence_ ] allf = (if compilerName == "hugs" then [] else [ apf "foldl" (t prop_foldl), @@ -341,14 +343,14 @@ apf "foldr" (t prop_foldr), apf "foldr'" (t prop_foldr'), apw "fold" (LLWrap prop_fold), - apf "foldMap" (t prop_foldMap) + apf "foldMap" (t prop_foldMap) ] alls = [ aps "toString" (t prop_toString), aps "fromString" (t prop_fromString), aps "lines" (t prop_lines), - aps "words" (t prop_words) + aps "words" (t prop_words) -- FIXME: aps (t prop_unlines), -- FIXME: aps (t prop_unwords) ] @@ -359,7 +361,11 @@ testh = HU.runTestTT $ allTests testv = runVerbTestText (HU.putTextToHandle stderr True) $ allTests - -main = - do testv - return () + +main = do + (counts, n) <- testv + case HU.errors counts + HU.failures counts of + 0 -> return () + n -> do + putStrLn ("counts=" ++ show counts ++ " n=" ++ show n) + exitWith (ExitFailure 1)