diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,68 @@ +CHANGES +======= + +#### 4.7.8.4 (2025-08-26) + + - fix build with `-Werror=incomplete-patterns` + - tested with GHC 8.0 - 9.14 alpha1 + +#### 4.7.8.3 (2025-03-13) + + - drop support for GHC 7 + - allow `containers-0.8` and up + - tested with GHC 8.0 - 9.12.1 + +#### 4.7.8.2 (2023-10-10) + + - pacify GHC 9.8's new `x-partial` warning + - tested with GHC 7.10 - 9.8 + +#### 4.7.8.1 (2023-07-12) + + - allow `bytestring-0.12` and fix its deprecation warnings + - tested with GHC 7.10 - 9.6 + +### 4.7.8 (2022-11-15) + + - change default `insertBy` implementation to work better with dlists + ([#18](https://github.com/ddssff/listlike/pull/18)) + - allow `vector-0.13` + - tested with GHC 7.10 - 9.4 + +### 4.7.7 (2022-05-26) + + - methods `sequence` and `mapM`: relax `Monad` constraint to `Applicative` + - `LANGUAGE TypeOperators` to fix GHC 9.4 warning + - allow `text-2.0` + - tested with GHC 7.10 - 9.4 + +### 4.7.6 (2021-09-01) + + - new implementation of `tail` in `DList` instance + - warning-free for `-Wall` and `-Wcompat` + +### 4.7.4 (2021-01-07) + + - support utf8-string-1.0.2 ([#10](https://github.com/ddssff/listlike/issues/10)) + +### 4.7.3 (2020-12-31) + + - support bytestring-0.10.12 ([#7](https://github.com/ddssff/listlike/pull/7)) for ghc 8.10.3 + - removed support for ghc 7.6 and 7.8 ([#6](https://github.com/ddssff/listlike/issues/6)) + +### 4.7.2 (2020-08-21) + + - support dlist-1.0 ([#4](https://github.com/ddssff/listlike/issues/4)) + +### 4.7.1 (2020-07-03) + + - support QuickCheck-2.14 + +## 4.7 + + - make `GHC.Exts.IsList` a superclass of `ListLike` and use its `fromList` and `toList` methods + - make `Data.String.IsString` a superclass of `Stringlike` and use its `fromString` method + - add methods to `StringLike`: `show`, `fromText`, `fromLazyText` + - add a class `ListOps`, alternative to `ListLike`, that uses the `GHC.Exts.Item` instead of + the `item` type parameter + - supply `instance IsString Seq` for old versions of container diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,4 +1,5 @@ Copyright (c) 2007-2010 John Goerzon and John Lato. +Copyright (c) 2018 David Fox All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/ListLike.cabal b/ListLike.cabal --- a/ListLike.cabal +++ b/ListLike.cabal @@ -1,17 +1,17 @@ +Cabal-Version: 1.18 Name: ListLike -Version: 3.1.7.1 +Version: 4.7.8.4 + License: BSD3 -Maintainer: John Lato +Maintainer: David Fox , Andreas Abel Author: John Goerzen Copyright: Copyright (c) 2007-2008 John Goerzen license-file: COPYRIGHT -extra-source-files: COPYRIGHT, README -Category: Generics -Cabal-Version: >= 1.6 +Category: list, string, text, bytestring, vector Build-Type: Simple -homepage: http://software.complete.org/listlike -synopsis: Generic support for list-like structures -Description: Generic support for list-like structures in Haskell. +homepage: http://github.com/ddssff/listlike +synopsis: Generalized support for list-like structures +Description: Generalized support for list-like structures in Haskell. . The ListLike module provides a common interface to the various Haskell types that are list-like. Predefined interfaces include standard @@ -23,29 +23,106 @@ infinite lists. Stability: Stable +Tested-With: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +extra-doc-files: + README.md + CHANGELOG.md + Library + default-language: Haskell2010 Hs-Source-Dirs: src - Exposed-Modules: Data.ListLike, - Data.ListLike.Base, - Data.ListLike.CharString, - Data.ListLike.FoldableLL, - Data.ListLike.IO, - Data.ListLike.Instances, - Data.ListLike.String, + Exposed-Modules: Data.ListLike + Data.ListLike.Base + Data.ListLike.Chars + Data.ListLike.CharString + Data.ListLike.FoldableLL + Data.ListLike.IO + Data.ListLike.Instances + Data.ListLike.String + Data.ListLike.Text + Data.ListLike.Text.Builder + Data.ListLike.Text.Text + Data.ListLike.Text.TextLazy + Data.ListLike.UTF8 Data.ListLike.Utils + Data.ListLike.Vector + Data.ListLike.Vector.Generic + Data.ListLike.Vector.Storable + Data.ListLike.Vector.Unboxed + Data.ListLike.Vector.Vector + Data.ListLike.DList + Data.ListLike.FMList -- Other-Modules: Data.ConfigFile.Lexer - Build-Depends: base >= 3 && < 5 - ,containers >= 0.3 && < 0.6 - ,bytestring >= 0.9.1 && < 0.11 - ,array >= 0.3 && < 0.5 - -Executable runtests - Buildable: False - Main-Is: runtests.hs - HS-Source-Dirs: testsrc, . - Extensions: ExistentialQuantification - UndecidableInstances, CPP + Build-Depends: + base >= 4.9 && < 5 + , containers >= 0.5.7 && < 1 + , bytestring >= 0.10.8 && < 0.13 + , array >= 0.5 && < 0.6 + , text >= 1.2 && < 1.3 || >= 2.0 && < 2.2 + , vector >= 0.12 && < 0.14 + , dlist >= 0.8 && < 1.1 + , fmlist >= 0.9 && < 0.10 + , utf8-string >= 1.0 && < 1.1 + , deepseq + -- Remark: Atm, we don't comply with the Haskell Package Versioning Policy + -- https://pvp.haskell.org/ + -- > ยง6. Client defines orphan instance. + -- > If a package defines an orphan instance, it MUST depend on the + -- > minor version of the packages that define the data type and the + -- > type class to be backwards compatible. For example, + -- > build-depends: mypkg >= 2.1.1 && < 2.1.2. + -- + -- Since ListLike defines orphan instances, we would need to include + -- the minor version number in the upper bounds. + -- (See issues #7 and #10.) + -- However, this could involve a maintenance marathon to relax upper bounds. + + If !impl(ghc >= 8.4) + Build-Depends: semigroups >= 0.16 && < 0.20 + + ghc-options: + -Wall + -Wcompat + +Test-suite listlike-tests + default-language: Haskell2010 + Hs-source-dirs: testsrc + Main-is: runtests.hs + Type: exitcode-stdio-1.0 + + Other-modules: TestInfrastructure + Build-depends: + base + , ListLike + , HUnit >= 1.5 && < 2 + , QuickCheck >= 2.9 && < 3 + , array + , bytestring + , containers + , dlist + , fmlist + , text + , vector + , utf8-string + If !impl(ghc >= 8.4) + Build-Depends: semigroups >= 0.16 && < 0.20 + source-repository head type: git - location: git://github.com/JohnLato/listlike.git + location: https://github.com/ddssff/listlike.git diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,10 +0,0 @@ -The ListLike package provides typeclasses and instances to allow -polymorphism over many common datatypes. - -The package can be built/installed with Cabal. If you have cabal-install, -simply run "cabal install ListLike" to install the package. Without -cabal-install, execute the following commands: - -$ runghc Setup.hs configure -$ runghc Setup.hs build -$ runghc Setup.hs install diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +[![Build Status](https://github.com/ddssff/listlike/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/ddssff/listlike/actions/workflows/haskell-ci.yml) +[![Hackage](https://img.shields.io/hackage/v/ListLike.svg)](https://hackage.haskell.org/package/ListLike) +[![Stackage Nightly](http://stackage.org/package/ListLike/badge/nightly)](http://stackage.org/nightly/package/ListLike) +[![Stackage LTS](http://stackage.org/package/ListLike/badge/lts)](http://stackage.org/lts/package/ListLike) + +ListLike +======== + +The `ListLike` package provides typeclasses and instances that +polymorphically generalize list operations to many list-like types +such as vectors, text, bytestrings, or difference lists. + +Read the [introduction](https://hackage.haskell.org/package/ListLike/docs/Data-ListLike.html). diff --git a/src/Data/ListLike.hs b/src/Data/ListLike.hs --- a/src/Data/ListLike.hs +++ b/src/Data/ListLike.hs @@ -12,8 +12,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Goerzen - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Generic operations over list-like structures @@ -23,13 +23,13 @@ Please start with the introduction at "Data.ListLike#intro". -} -module Data.ListLike +module Data.ListLike (-- * Introduction -- $intro - + -- * Creation & Basic Functions - empty, singleton, - cons, snoc, append, head, last, tail, init, null, length, + empty, singleton, + cons, snoc, append, uncons, head, last, tail, init, null, length, -- * List transformations map, rigidMap, reverse, intersperse, -- ** Conversions @@ -51,10 +51,12 @@ -- ** Unfolding -- * Sublists -- ** Extracting sublists - take, drop, splitAt, takeWhile, dropWhile, span, break, - group, inits, tails, + take, drop, splitAt, takeWhile, dropWhile, dropWhileEnd, span, break, + group, inits, tails, -- ** Predicates isPrefixOf, isSuffixOf, isInfixOf, + -- ** Modify based on predicate + stripPrefix, stripSuffix, -- * Searching lists -- ** Searching by equality elem, notElem, @@ -70,7 +72,8 @@ ListLikeIO(..), -- * Special lists -- ** Strings - toString, fromString, lines, words, + toString, fromString, lines, words, show, + fromStringLike, fromText, fromLazyText, -- ** \"Set\" operations nub, delete, deleteFirsts, union, intersect, -- ** Ordered lists @@ -95,12 +98,13 @@ -- ** ByteStrings -- $notesbytestring + Chars(..), CharString (..), CharStringLazy (..), -- * Base Typeclasses -- ** The ListLike class - ListLike, + ListLike, ListOps, -- ** The FoldableLL class FoldableLL, -- ** The StringLike class @@ -109,18 +113,21 @@ InfiniteListLike ) where -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, - sequence_, mapM, mapM_, concatMap, and, or, sum, - product, repeat, replicate, cycle, take, drop, - splitAt, elem, notElem, unzip, lines, words, - unlines, unwords) +import Prelude hiding (Foldable(..), head, last, tail, map, filter, concat, + any, lookup, init, all, + iterate, span, break, takeWhile, + dropWhile, {-dropWhileEnd,-} reverse, zip, zipWith, sequence, + sequence_, mapM, mapM_, concatMap, and, or, + repeat, replicate, cycle, take, drop, + splitAt, notElem, unzip, lines, words, + unlines, unwords, show) import Data.ListLike.Base +import Data.ListLike.Chars import Data.ListLike.CharString import Data.ListLike.FoldableLL -import Data.ListLike.Instances() +import Data.ListLike.Instances () +import Data.ListLike.DList () +import Data.ListLike.FMList () import Data.ListLike.String import Data.ListLike.Utils import Data.ListLike.IO @@ -157,7 +164,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. -} @@ -220,7 +227,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 @@ -1,9 +1,13 @@ {-# LANGUAGE ScopedTypeVariables + ,TypeFamilies ,MultiParamTypeClasses ,FunctionalDependencies ,FlexibleInstances ,BangPatterns - ,FlexibleContexts #-} + ,FlexibleContexts + ,ConstraintKinds + ,CPP #-} +{-# LANGUAGE TypeOperators #-} -- for GHC >= 9.4 {- Copyright (C) 2007 John Goerzen @@ -19,8 +23,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Generic operations over list-like structures @@ -28,25 +32,32 @@ Written by John Goerzen, jgoerzen\@complete.org -} -module Data.ListLike.Base +module Data.ListLike.Base ( - ListLike(..), + ListLike(..), ListOps, + toList, fromList, InfiniteListLike(..), zip, zipWith, sequence_ ) where -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, - sequence_, mapM, mapM_, concatMap, and, or, sum, - product, repeat, replicate, cycle, take, drop, - splitAt, elem, notElem, unzip, lines, words, - unlines, unwords) + +import Prelude + ( Applicative(..), Bool(..), Eq(..), Int, Integer, Integral + , Maybe(..), Monad, Monoid(..), Num(..), Ord(..), Ordering(..) + , ($), (.), (&&), (||), (++), asTypeOf, error, flip, fst, snd + , id, maybe, max, min, not, otherwise + , sequenceA + ) +#if MIN_VERSION_base(4,17,0) +import Data.Type.Equality -- GHC 9.4: type equality ~ is just an operator now +#endif + import qualified Data.List as L import Data.ListLike.FoldableLL -import qualified Control.Monad as M -import Data.Monoid -import Data.Maybe + ( FoldableLL(foldr, foldr1, foldl), fold, foldMap, sequence_ ) +import qualified Control.Applicative as A +import Data.Monoid ( All(All, getAll), Any(Any, getAny) ) +import Data.Maybe ( listToMaybe ) +import GHC.Exts (IsList(Item, fromList, {-fromListN,-} toList)) {- | The class implementing list-like functions. @@ -66,7 +77,7 @@ * null or genericLength -} -class (FoldableLL full item, Monoid full) => +class (IsList full, item ~ Item full, FoldableLL full item, Monoid full) => ListLike full item | full -> item where ------------------------------ Creation @@ -88,12 +99,17 @@ snoc l item = append l (singleton item) {- | Combines two lists. Like (++). -} - append :: full -> full -> full + append :: full -> full -> full append = mappend {- | Extracts the first element of a 'ListLike'. -} head :: full -> item + head = maybe (error "head") fst . uncons + {- | Extract head and tail, return Nothing if empty -} + uncons :: full -> Maybe (item, full) + uncons x = if null x then Nothing else Just (head x, tail x) -- please don't + {- | Extracts the last element of a 'ListLike'. -} last :: full -> item last l = case genericLength l of @@ -102,7 +118,8 @@ _ -> last (tail l) {- | Gives all elements after the head. -} - tail :: full -> full + tail :: full -> full + tail = maybe (error "tail") snd . uncons {- | All elements of the list except the last one. See also 'inits'. -} init :: full -> full @@ -127,7 +144,7 @@ as fast, if not faster, than this function and is recommended if it will work for your purposes. See also 'mapM'. -} map :: ListLike full' item' => (item -> item') -> full -> full' - map func inp + map func inp | null inp = empty | otherwise = cons (func (head inp)) (map func (tail inp)) @@ -139,7 +156,7 @@ rigidMap = map {- | Reverse the elements in a list. -} - reverse :: full -> full + reverse :: full -> full reverse l = rev l empty where rev rl a | null rl = a @@ -158,7 +175,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. @@ -210,13 +227,13 @@ {- | Returns all elements at start of list that satisfy the function. -} takeWhile :: (item -> Bool) -> full -> full - takeWhile func l + takeWhile func l | null l = empty | func x = cons x (takeWhile func (tail l)) | otherwise = empty where x = head l - {- | Drops all elements form the start of the list that satisfy the + {- | Drops all elements from the start of the list that satisfy the function. -} dropWhile :: (item -> Bool) -> full -> full dropWhile func l @@ -224,11 +241,16 @@ | func (head l) = dropWhile func (tail l) | otherwise = l + {- | Drops all elements from the end of the list that satisfy the + function. -} + dropWhileEnd :: (item -> Bool) -> full -> full + dropWhileEnd func = foldr (\x xs -> if func x && null xs then empty else cons x xs) empty + {- | The equivalent of @('takeWhile' f xs, 'dropWhile' f xs)@ -} span :: (item -> Bool) -> full -> (full, full) span func l | null l = (empty, empty) - | func x = (cons x ys, zs) + | func x = (cons x ys, zs) | otherwise = (empty, l) where (ys, zs) = span func (tail l) x = head l @@ -263,7 +285,7 @@ isPrefixOf needle haystack | null needle = True | null haystack = False - | otherwise = (head needle) == (head haystack) && + | otherwise = (head needle) == (head haystack) && isPrefixOf (tail needle) (tail haystack) {- | True when the first list is at the beginning of the second. -} @@ -272,10 +294,23 @@ {- | True when the first list is wholly containted within the second -} isInfixOf :: Eq item => full -> full -> Bool - isInfixOf needle haystack = + isInfixOf needle haystack = any (isPrefixOf needle) thetails where thetails = asTypeOf (tails haystack) [haystack] + ------------------------------ Conditionally modify based on predicates + {- | Remove a prefix from a listlike if possible -} + stripPrefix :: Eq item => full -> full -> Maybe full + stripPrefix xs ys = if xs `isPrefixOf` ys + then Just $ drop (length xs) ys + else Nothing + + {- | Remove a suffix from a listlike if possible -} + stripSuffix :: Eq item => full -> full -> Maybe full + stripSuffix xs ys = if xs `isSuffixOf` ys + then Just $ take (length ys - length xs) ys + else Nothing + ------------------------------ Searching {- | True if the item occurs in the list -} elem :: Eq item => item -> full -> Bool @@ -293,8 +328,8 @@ Just x -> Just (index l x) {- | Returns only the elements that satisfy the function. -} - filter :: (item -> Bool) -> full -> full - filter func l + filter :: (item -> Bool) -> full -> full + filter func l | null l = empty | func (head l) = cons (head l) (filter func (tail l)) | otherwise = filter func (tail l) @@ -308,7 +343,7 @@ {- | The element at 0-based index i. Raises an exception if i is out of bounds. Like (!!) for lists. -} index :: full -> Int -> item - index l i + index l i | null l = error "index: index not found" | i < 0 = error "index: index must be >= 0" | i == 0 = head l @@ -318,7 +353,7 @@ elemIndex :: Eq item => item -> full -> Maybe Int elemIndex e l = findIndex (== e) l - {- | Returns the indices of the matching elements. See also + {- | Returns the indices of the matching elements. See also 'findIndices' -} elemIndices :: (Eq item, ListLike result Int) => item -> full -> result elemIndices i l = findIndices (== i) l @@ -335,18 +370,14 @@ ------------------------------ Monadic operations {- | Evaluate each action in the sequence and collect the results -} - sequence :: (Monad m, ListLike fullinp (m item)) => + sequence :: (Applicative m, ListLike fullinp (m item)) => fullinp -> m full - sequence l = foldr func (return empty) l - where func litem results = - do x <- litem - xs <- results - return (cons x xs) + sequence = foldr (A.liftA2 cons) (pure empty) - {- | A map in monad space. Same as @'sequence' . 'map'@ - + {- | A map in monad space. Same as @'sequence' . 'map'@ + See also 'rigidMapM' -} - mapM :: (Monad m, ListLike full' item') => + mapM :: (Applicative m, ListLike full' item') => (item -> m item') -> full -> m full' mapM func l = sequence mapresult where mapresult = asTypeOf (map func l) [] @@ -391,40 +422,51 @@ sort = sortBy compare {- | Inserts the element at the last place where it is still less than or - equal to the next element. On data types that do not preserve + equal to the next element. On data types that do not preserve ordering, or enforce their own ordering, the result may not be what you expect. On types such as maps, this may result in changing an existing item. See also 'insertBy'. -} - insert :: Ord item => item -> full -> full + insert :: Ord item => item -> full -> full insert = insertBy compare ------------------------------ Conversions {- | Converts the structure to a list. This is logically equivolent - to 'fromListLike', but may have a more optimized implementation. -} - toList :: full -> [item] - toList = fromListLike + to 'fromListLike', but may have a more optimized implementation. + These two functions are now retired in favor of the methods of + IsList, but they are retained here because some instances still + use this implementation. -} + toList' :: full -> [item] + toList' = fromListLike {- | Generates the structure from a list. -} - fromList :: [item] -> full - fromList [] = empty - fromList (x:xs) = cons x (fromList xs) + fromList' :: [item] -> full + fromList' [] = empty + fromList' (x:xs) = cons x (fromList xs) - {- | Converts one ListLike to another. See also 'toList'. + {- | Converts one ListLike to another. See also 'toList''. Default implementation is @fromListLike = map id@ -} fromListLike :: ListLike full' item => full -> full' fromListLike = map id + {-# INLINE fromListLike #-} ------------------------------ 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 @@ -455,7 +497,7 @@ intersectBy func xs ys = filter (\x -> any (func x) ys) xs {- | Generic version of 'group'. -} - groupBy :: (ListLike full' full, Eq item) => + groupBy :: (ListLike full' full, Eq item) => (item -> item -> Bool) -> full -> full' groupBy eq l | null l = empty @@ -465,16 +507,17 @@ xs = tail l {- | Sort function taking a custom comparison function -} - sortBy :: (item -> item -> Ordering) -> full -> full + sortBy :: (item -> item -> Ordering) -> full -> full sortBy cmp = foldr (insertBy cmp) empty {- | Like 'insert', but with a custom comparison function -} insertBy :: (item -> item -> Ordering) -> item -> - full -> full - insertBy cmp x ys - | null ys = singleton x - | otherwise = case cmp x (head ys) of - GT -> cons (head ys) (insertBy cmp x (tail ys)) + full -> full + insertBy cmp x ys = + case uncons ys of + Nothing -> singleton x + Just (ys_head,ys_tail) -> case cmp x ys_head of + GT -> cons ys_head (insertBy cmp x ys_tail) _ -> cons x ys ------------------------------ Generic Operations @@ -495,7 +538,7 @@ {- | Generic version of 'drop' -} genericDrop :: Integral a => a -> full -> full - genericDrop n l + genericDrop n l | n <= 0 = l | null l = l | otherwise = genericDrop (n - 1) (tail l) @@ -506,10 +549,21 @@ {- | Generic version of 'replicate' -} genericReplicate :: Integral a => a -> item -> full - genericReplicate count x + genericReplicate count x | count <= 0 = empty | otherwise = map (\_ -> x) [1..count] + + {-# MINIMAL (singleton, uncons, null) | + (singleton, uncons, genericLength) | + (singleton, head, tail, null) | + (singleton, head, tail, genericLength) #-} + + +-- | A version of 'ListLike' with a single type parameter, the item +-- type is obtained using the 'Item' type function from 'IsList'. +type ListOps full = (ListLike full (Item full)) + {- instance (ListLike full item) => Monad full where m >>= k = foldr (append . k) empty m @@ -538,7 +592,7 @@ {- | Converts a finite list into a circular one -} cycle :: full -> full - cycle xs + cycle xs | null xs = error "ListLike.cycle: empty list" | otherwise = xs' where xs' = append xs xs' @@ -551,9 +605,11 @@ cons x l = x : l snoc l x = l ++ [x] append = (++) - head = L.head + -- Andreas Abel, 2023-10-10, issue #32: + -- Use implementation of 'head' and 'tail' in terms of 'uncons' to avoid the x-partial warning under GHC 9.8 + uncons [] = Nothing + uncons (x : xs) = Just (x, xs) last = L.last - tail = L.tail init = L.init null = L.null length = L.length @@ -561,8 +617,6 @@ rigidMap = L.map reverse = L.reverse intersperse = L.intersperse - toList = id - fromList = id -- fromListLike = toList concat = L.concat . toList -- concatMap func = fromList . L.concatMap func @@ -587,6 +641,7 @@ isPrefixOf = L.isPrefixOf isSuffixOf = L.isSuffixOf isInfixOf = L.isInfixOf + stripPrefix = L.stripPrefix elem = L.elem notElem = L.notElem find = L.find @@ -596,7 +651,7 @@ elemIndex = L.elemIndex elemIndices item = fromList . L.elemIndices item findIndex = L.findIndex - sequence = M.sequence . toList + sequence = sequenceA . toList -- mapM = M.mapM nub = L.nub delete = L.delete @@ -621,7 +676,7 @@ ListLike fullb itemb, ListLike result (item, itemb)) => full -> fullb -> result -zip = zipWith (\a b -> (a, b)) +zip = zipWith (,) {- | Takes two lists and combines them with a custom combining function -} zipWith :: (ListLike full item, 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 @@ -1,6 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + ,MultiParamTypeClasses ,FlexibleInstances - ,TypeSynonymInstances #-} + ,TypeFamilies + ,TypeSynonymInstances + ,GeneralizedNewtypeDeriving #-} {- @@ -17,8 +20,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Newtype wrapper for ByteString to enable a Char-based interface @@ -34,7 +37,7 @@ 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, @@ -42,18 +45,22 @@ 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 import Data.ListLike.FoldableLL import Data.Int -import Data.Monoid +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif +import Data.String (IsString(..)) 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 +import GHC.Exts (IsList(..)) -------------------------------------------------- -- ByteString @@ -61,11 +68,7 @@ -- | Newtype wrapper around Data.ByteString.Char8.ByteString, -- this allows for ListLike instances with Char elements. newtype CharString = CS { unCS :: BS.ByteString } - deriving (Read, Show, Eq, Ord) - -instance Monoid CharString where - mempty = CS mempty - mappend l r = CS $ mappend (unCS l) (unCS r) + deriving (Read, Show, Eq, Ord, Semigroup, Monoid) instance FoldableLL CharString Char where foldl f i0 ls = BS.foldl f i0 (unCS ls) @@ -74,6 +77,11 @@ foldr f i0 ls = BS.foldr f i0 (unCS ls) foldr1 f ls = BS.foldr1 f (unCS ls) +instance IsList CharString where + type Item CharString = Char + toList = BS.unpack . unCS + fromList = CS . BS.pack + instance ListLike CharString Char where empty = CS BS.empty singleton = CS . BS.singleton @@ -131,9 +139,9 @@ --intersect = BS.intersect --sort = BS.sort --insert = BS.insert - toList = BS.unpack . unCS - fromList = CS . BS.pack - fromListLike = fromList . toList + --toList = BS.unpack . unCS + --fromList = CS . BS.pack + --fromListLike = fromList . toList --nubBy = BS.nubBy --deleteBy = BS.deleteBy --deleteFirstsBy = BS.deleteFirstsBy @@ -166,9 +174,11 @@ writeFile fp = BS.writeFile fp . unCS appendFile fp = BS.appendFile fp . unCS +instance IsString CharString where + fromString = CS . BS.pack + instance StringLike CharString where toString = BS.unpack . unCS - fromString = CS . BS.pack -------------------------------------------------- -- ByteString.Lazy @@ -176,11 +186,7 @@ -- | Newtype wrapper around Data.ByteString.Lazy.Char8.ByteString, -- this allows for ListLike instances with Char elements. newtype CharStringLazy = CSL { unCSL :: BSL.ByteString } - deriving (Read, Show, Eq, Ord) - -instance Monoid CharStringLazy where - mempty = CSL mempty - mappend l r = CSL $ mappend (unCSL l) (unCSL r) + deriving (Read, Show, Eq, Ord, Semigroup, Monoid) instance FoldableLL CharStringLazy Char where foldl f i0 ls = BSL.foldl f i0 (unCSL ls) @@ -193,6 +199,11 @@ mi64toi Nothing = Nothing mi64toi (Just x) = Just (fromIntegral x) +instance IsList CharStringLazy where + type Item CharStringLazy = Char + toList = BSL.unpack . unCSL + fromList = CSL . BSL.pack + instance ListLike CharStringLazy Char where empty = CSL BSL.empty singleton = CSL . BSL.singleton @@ -250,9 +261,9 @@ --intersect = BSL.intersect --sort = BSL.sort --insert = BSL.insert - toList = BSL.unpack . unCSL - fromList = CSL . BSL.pack - fromListLike = fromList . toList + --toList = BSL.unpack . unCSL + --fromList = CSL . BSL.pack + --fromListLike = fromList . toList --nubBy = BSL.nubBy --deleteBy = BSL.deleteBy --deleteFirstsBy = BSL.deleteFirstsBy @@ -288,6 +299,8 @@ writeFile fp = BSL.writeFile fp . unCSL appendFile fp = BSL.appendFile fp . unCSL +instance IsString CharStringLazy where + fromString = CSL . BSL.pack + instance StringLike CharStringLazy where toString = BSL.unpack . unCSL - fromString = CSL . BSL.pack diff --git a/src/Data/ListLike/Chars.hs b/src/Data/ListLike/Chars.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Chars.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP + ,MultiParamTypeClasses + ,TypeFamilies + ,FlexibleInstances #-} + +module Data.ListLike.Chars + +where + +import Control.DeepSeq +--import Control.Monad +import Data.String as String (IsString) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif +import qualified Data.Text.Lazy as T +--import qualified Data.Text.Lazy.IO as TI +import qualified Data.Text.Lazy.Builder as Builder +--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 GHC.Exts (IsList(..)) + +data Chars + = B Builder.Builder + | T T.Text + deriving (Show, Eq, Ord) + +builder :: Chars -> Builder.Builder +builder (B x) = x +builder (T s) = Builder.fromLazyText s +{-# INLINE builder #-} + +instance Semigroup Chars where + a <> b = B $ builder a <> builder b + +instance Monoid Chars where + mempty = B mempty + mappend = (<>) + +instance String.IsString Chars where + -- Builder already has an IsString instance, do we want to use it? + -- fromString = B . String.fromString + -- or do we want the implementation that used to be in the StringLike instance? + fromString = B . Builder.fromLazyText . LL.fromString + +instance FoldableLL Chars Char where + foldl f r0 (B b) = LL.foldl f r0 . Builder.toLazyText $ b + foldl f r0 (T s) = LL.foldl f r0 $ s + foldr f r0 (B b) = LL.foldr f r0 . Builder.toLazyText $ b + foldr f r0 (T s) = LL.foldr f r0 $ s + -- + foldl' f r0 (B b) = LL.foldl' f r0 . Builder.toLazyText $ b + foldl' f r0 (T s) = LL.foldl' f r0 $ s + foldl1 f (B b) = LL.foldl1 f . Builder.toLazyText $ b + foldl1 f (T s) = LL.foldl1 f $ s + foldr' f r0 (B b) = LL.foldr' f r0 . Builder.toLazyText $ b + foldr' f r0 (T s) = LL.foldr' f r0 $ s + foldr1 f (B b) = LL.foldr1 f . Builder.toLazyText $ b + foldr1 f (T s) = LL.foldr1 f $ s + +instance IsList Chars where + type Item Chars = Char + toList = LL.toList' + fromList = LL.fromList' + +instance ListLike Chars Char where + singleton = B . Builder.singleton + uncons (B b) = + case LL.uncons (Builder.toLazyText b) of + Nothing -> Nothing + Just (c, s) -> Just (c, T s) + uncons (T s) = + case LL.uncons s of + Nothing -> Nothing + Just (c, s') -> Just (c, T s') + null (B b) = LL.null . Builder.toLazyText $ b + null (T t) = LL.null t + +instance ListLikeIO Chars Char where + hGetLine h = T <$> hGetLine h + hGetContents h = T <$> hGetContents h + hGet h n = T <$> hGet h n + hGetNonBlocking h n = T <$> hGetNonBlocking h n + hPutStr h (B b) = hPutStr h . Builder.toLazyText $ b + hPutStr h (T s) = hPutStr h $ s + +instance StringLike Chars where + toString (B b) = toString . Builder.toLazyText $ b + toString (T s) = toString $ s + fromLazyText = B . Builder.fromLazyText + fromText = B . Builder.fromText + +instance NFData Chars where + rnf (B b) = rnf . Builder.toLazyText $ b + rnf (T s) = rnf s diff --git a/src/Data/ListLike/DList.hs b/src/Data/ListLike/DList.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/DList.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE CPP #-} + +-- | 'Data.ListLike.ListLike' instances for 'Data.DList.DList' + +module Data.ListLike.DList () where + +import qualified Prelude + +import Data.ListLike.Base +import Data.ListLike.FoldableLL +import Data.ListLike.String +#if MIN_VERSION_dlist(1,0,0) +import Data.DList.Unsafe (DList(UnsafeDList), unsafeApplyDList) +#else +import Data.DList (DList) +#endif +import qualified Data.DList as D +import qualified Data.Foldable as F +import qualified Data.List as List +import qualified Data.String as S +import Control.Category +import Data.Char (Char) + + +instance FoldableLL (DList a) a where + foldl = F.foldl + foldr = D.foldr + foldl1 = F.foldl1 + foldr1 = F.foldr1 + foldl' = F.foldl' + foldr' = F.foldr' + +instance ListLike (DList a) a where + empty = D.empty + singleton = D.singleton + cons = D.cons + snoc = D.snoc + append = D.append + head = D.head +#if MIN_VERSION_dlist(1,0,0) + -- Andreas Abel, 2021-09-01, issue #14, + -- work around https://github.com/spl/dlist/issues/98: + -- + -- dlist-1.0 changed @tail@ so that it is not an operation + -- on difference lists anymore, but collapses the difference list + -- into a plain list. + -- + -- The following tail function restores the spirit of difference + -- lists, at the cost of breaking data abstraction, i.e., + -- using the constructor and destructor of the newtype DList. + -- Andreas Abel, 2023-10-10, issue #32: + -- Use @drop 1@ instead of @tail@ as the latter triggers the x-partial warning in GHC 9.8. + tail = UnsafeDList . (List.drop 1 .) . unsafeApplyDList +#else + tail = D.tail +#endif + rigidMap = D.map + null = null . D.toList + --toList = D.toList + --fromList = D.fromList + replicate = D.replicate + uncons xs = case xs of + D.Nil -> Prelude.Nothing + D.Cons d_head l_tail -> Prelude.Just (d_head,fromList l_tail) + _ -> Prelude.error "Workaround for missing COMPLETE pragma on dlist patterns" + + +instance StringLike (DList Char) where + toString = D.toList + -- fromString = D.fromList + lines = map D.fromList . S.lines . D.toList + words = map D.fromList . S.words . D.toList + unlines = D.fromList . S.unlines . map D.toList + unwords = D.fromList . S.unwords . map D.toList diff --git a/src/Data/ListLike/FMList.hs b/src/Data/ListLike/FMList.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/FMList.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS -Wno-orphans #-} +-- | 'Data.ListLike.ListLike' instances for 'Data.FMList.FMList' +module Data.ListLike.FMList () where +import Prelude hiding (cycle, map) +import Data.ListLike.Base +import Data.ListLike.FoldableLL +--import Data.ListLike.IO +import Data.ListLike.String +import Data.FMList (FMList(..)) +import qualified Data.FMList as FM +--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 qualified Data.String as S +import Control.Monad.Zip (MonadZip) +import qualified Control.Monad.Zip as Z +--import Data.Function +import GHC.Exts (IsList(..)) + +instance FoldableLL (FMList a) a where + foldl = F.foldl + foldr = F.foldr + foldl1 = F.foldl1 + foldr1 = F.foldr1 + foldl' = F.foldl' + foldr' = F.foldr' + +instance IsList (FMList a) where + type Item (FMList a) = a + fromList = FM.fromList + toList = FM.toList + +instance ListLike (FMList a) a where + empty = FM.empty + singleton = FM.singleton + cons = FM.cons + snoc = FM.snoc + append = FM.append + head = FM.head + tail = FM.tail + last = FM.last + init = FM.init + --fromList = FM.fromList + --toList = FM.toList + null = FM.null + genericLength = FM.genericLength + length = FM.length + reverse = FM.reverse + filter = FM.filter + take = FM.take + takeWhile = FM.takeWhile + drop = FM.drop + dropWhile = FM.dropWhile + +instance InfiniteListLike (FMList a) a where + iterate = FM.iterate + repeat = FM.repeat + cycle a = (a `FM.append` cycle a) `FM.append` a + +instance IsString (FMList Char) where + fromString = FM.fromList + +instance StringLike (FMList Char) where + toString = FM.toList + lines = map FM.fromList . S.lines . FM.toList + words = map FM.fromList . S.words . FM.toList + unlines = FM.fromList . S.unlines . map FM.toList + unwords = FM.fromList . S.unwords . map FM.toList + +instance MonadZip FMList where + mzipWith = FM.zipWith 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 #-} @@ -15,8 +16,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Generic tools for data structures that can be folded. @@ -24,19 +25,18 @@ Written by John Goerzen, jgoerzen\@complete.org -} -module Data.ListLike.FoldableLL +module Data.ListLike.FoldableLL (-- * FoldableLL Class FoldableLL(..), -- * Utilities fold, foldMap, foldM, sequence_, mapM_ - ) where -import Prelude hiding (foldl, foldr, foldr1, sequence_, mapM_) + ) where +import Prelude hiding (foldl, foldr, foldr1, sequence_, mapM_, foldMap) import qualified Data.Foldable as F -import Data.Monoid import Data.Maybe import qualified Data.List as L -{- | This is the primary class for structures that are to be considered +{- | This is the primary class for structures that are to be considered foldable. A minimum complete definition provides 'foldl' and 'foldr'. Instances of 'FoldableLL' can be folded, and can be many and varied. diff --git a/src/Data/ListLike/IO.hs b/src/Data/ListLike/IO.hs --- a/src/Data/ListLike/IO.hs +++ b/src/Data/ListLike/IO.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE MultiParamTypeClasses ,FunctionalDependencies #-} @@ -16,8 +16,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable String-like functions @@ -29,7 +29,7 @@ ( ListLikeIO(..) ) 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, @@ -48,7 +48,7 @@ Note that some types may not be capable of lazy reading or writing. Therefore, the usual semantics of "System.IO" functions regarding laziness may or may not be available from a particular implementation. - + Minimal complete definition: * hGetLine @@ -104,7 +104,7 @@ -- | Interact with stdin and stdout by using a function to transform -- input to output. May be lazy. See 'System.IO.interact' for more. interact :: (full -> full) -> IO () - interact func = + interact func = do c <- getContents putStr (func c) 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,12 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + ,MultiParamTypeClasses ,FlexibleInstances + ,TypeFamilies ,TypeSynonymInstances #-} - +{-# OPTIONS -Wno-orphans #-} +#if __GLASGOW_HASKELL__ >= 900 +{-# OPTIONS -Wno-incomplete-uni-patterns #-} +#endif {- Copyright (C) 2007 John Goerzen @@ -17,8 +22,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Instances of 'Data.ListLike.ListLike' and related classes. @@ -28,7 +33,7 @@ -} module Data.ListLike.Instances () 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, @@ -37,7 +42,6 @@ splitAt, elem, notElem, unzip, lines, words, unlines, unwords) import qualified Prelude as P -import Control.Monad import qualified Data.List as L import qualified Data.Sequence as S import Data.Sequence ((><), (|>), (<|)) @@ -46,18 +50,27 @@ import Data.ListLike.String import Data.ListLike.IO import Data.ListLike.FoldableLL +import Data.ListLike.Text () +import Data.ListLike.UTF8 () +import Data.ListLike.Vector () import Data.Int -import Data.Monoid +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif 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 (IsString) +--import Data.String.UTF8 (UTF8) +--import qualified Data.String.UTF8 as UTF8 import qualified System.IO as IO import Data.Word +import GHC.Exts (IsList(..)) -------------------------------------------------- -- [] @@ -68,8 +81,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 @@ -80,9 +95,27 @@ 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 + --fromString = id instance InfiniteListLike [a] a where iterate = L.iterate @@ -100,12 +133,20 @@ foldr' = BS.foldr' foldr1 = BS.foldr1 +#if !MIN_VERSION_bytestring(0,10,12) +instance IsList BS.ByteString where + type Item BS.ByteString = Word8 + toList = BS.unpack + fromList = BS.pack +#endif + instance ListLike BS.ByteString Word8 where empty = BS.empty singleton = BS.singleton cons = BS.cons snoc = BS.snoc append = BS.append + uncons = BS.uncons head = BS.head last = BS.last tail = BS.tail @@ -149,8 +190,8 @@ findIndices x = fromList . BS.findIndices x -- the default definitions don't work well for array-like things, so -- do monadic stuff via a list instead - sequence = liftM fromList . P.sequence . toList - mapM func = liftM fromList . P.mapM func . toList + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList --nub = BS.nub --delete = BS.delete --deleteFirsts = BS.deleteFirsts @@ -158,9 +199,7 @@ --intersect = BS.intersect sort = BS.sort --insert = BS.insert - toList = BS.unpack - fromList = BS.pack - fromListLike = fromList . toList + --fromListLike = fromList . toList --nubBy = BS.nubBy --deleteBy = BS.deleteBy --deleteFirstsBy = BS.deleteFirstsBy @@ -176,13 +215,13 @@ genericReplicate i = BS.replicate (fromIntegral i) instance ListLikeIO BS.ByteString Word8 where - hGetLine = BS.hGetLine + hGetLine = BSC.hGetLine hGetContents = BS.hGetContents hGet = BS.hGet hGetNonBlocking = BS.hGetNonBlocking hPutStr = BS.hPutStr hPutStrLn = BSC.hPutStrLn - getLine = BS.getLine + getLine = BSC.getLine getContents = BS.getContents putStr = BS.putStr putStrLn = BSC.putStrLn @@ -191,9 +230,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 @@ -210,12 +258,20 @@ mi64toi Nothing = Nothing mi64toi (Just x) = Just (fromIntegral x) +#if !MIN_VERSION_bytestring(0,10,12) +instance IsList BSL.ByteString where + type Item BSL.ByteString = Word8 + toList = BSL.unpack + fromList = BSL.pack +#endif + instance ListLike BSL.ByteString Word8 where empty = BSL.empty singleton = BSL.singleton cons = BSL.cons snoc = BSL.snoc append = BSL.append + uncons = BSL.uncons head = BSL.head last = BSL.last tail = BSL.tail @@ -253,12 +309,12 @@ filter = BSL.filter --partition = BSL.partition index l i = BSL.index l (fromIntegral i) - elemIndex i = mi64toi . BSL.elemIndex i + elemIndex i = mi64toi . BSL.elemIndex i --elemIndices x = fromList . L.map fromIntegral . BSL.elemIndices x findIndex f = mi64toi . BSL.findIndex f --findIndices x = fromList . L.map fromIntegral . BSL.findIndices x - sequence = liftM fromList . P.sequence . toList - mapM func = liftM fromList . P.mapM func . toList + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList --sequence = BSL.sequence --mapM = BSL.mapM --mapM_ = BSL.mapM_ @@ -269,9 +325,7 @@ --intersect = BSL.intersect --sort = BSL.sort --insert = BSL.insert - toList = BSL.unpack - fromList = BSL.pack - fromListLike = fromList . toList + --fromListLike = fromList . toList --nubBy = BSL.nubBy --deleteBy = BSL.deleteBy --deleteFirstsBy = BSL.deleteFirstsBy @@ -291,13 +345,13 @@ strict2lazy :: BS.ByteString -> IO BSL.ByteString strict2lazy b = return (BSL.fromChunks [b]) instance ListLikeIO BSL.ByteString Word8 where - hGetLine h = BS.hGetLine h >>= strict2lazy + hGetLine h = BSC.hGetLine h >>= strict2lazy hGetContents = BSL.hGetContents hGet = BSL.hGet hGetNonBlocking = BSL.hGetNonBlocking hPutStr = BSL.hPut -- hPutStrLn = BSLC.hPutStrLn - getLine = BS.getLine >>= strict2lazy + getLine = BSC.getLine >>= strict2lazy getContents = BSL.getContents putStr = BSL.putStr putStrLn = BSLC.putStrLn @@ -306,9 +360,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 @@ -323,7 +379,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' @@ -331,25 +388,33 @@ foldr1 = F.foldr1 foldr' = F.foldr' +instance (Integral i, Ix i) => Semigroup (A.Array i e) where + l1 <> l2 = A.array (blow, newbhigh) $ + A.assocs l1 ++ zip [bhigh + 1 .. newbhigh] (A.elems l2) + where + newlen = genericLength newelems + newelems = A.elems l2 + newbhigh = bhigh + newlen + (blow, bhigh) = A.bounds l1 + instance (Integral i, Ix i) => Monoid (A.Array i e) where - mempty = A.listArray (0, -1) [] - mappend l1 l2 = - A.array (blow, newbhigh) - (A.assocs l1 ++ zip [(bhigh + 1)..newbhigh] (A.elems l2)) - where newlen = genericLength newelems - newelems = A.elems l2 - newbhigh = bhigh + newlen - (blow, bhigh) = A.bounds l1 + mempty = A.listArray (0, -1) [] + mappend = (<>) +instance (Integral i, Ix i) => IsList (A.Array i e) where + type Item (A.Array i e) = e + toList = A.elems + fromList l = A.listArray (0, genericLength l - 1) l + instance (Integral i, Ix i) => ListLike (A.Array i e) e where empty = mempty singleton i = A.listArray (0, 0) [i] - cons i l = + cons i l = -- To add something to the beginning of an array, we must -- change the bounds and set the first element. (A.ixmap (blow - 1, bhigh) id l) // [(blow - 1, i)] where (blow, bhigh) = A.bounds l - snoc l i = + snoc l i = -- Here we must change the bounds and set the last element (A.ixmap (blow, bhigh + 1) id l) // [(bhigh + 1, i)] where (blow, bhigh) = A.bounds l @@ -364,7 +429,7 @@ length = genericLength -- map rigidMap = A.amap - reverse l = A.listArray (A.bounds l) (L.reverse (A.elems l)) + reverse l = A.listArray (A.bounds l) (L.reverse (A.elems l)) -- intersperse -- concat -- concatMap @@ -397,8 +462,8 @@ elemIndices i = fromList . L.elemIndices i . toList findIndex f = L.findIndex f . toList findIndices f = fromList . L.findIndices f . toList - sequence = liftM fromList . P.sequence . toList - mapM func = liftM fromList . P.mapM func . toList + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList -- rigidMapM = mapM nub = fromList . L.nub . toList -- delete @@ -407,8 +472,6 @@ -- intersect sort l = A.listArray (A.bounds l) (L.sort (A.elems l)) -- insert - toList = A.elems - fromList l = A.listArray (0, genericLength l - 1) l -- fromListLike nubBy f = fromList . L.nubBy f . toList -- deleteBy @@ -420,7 +483,7 @@ -- insertBy genericLength l = fromIntegral (bhigh - blow + 1) where (blow, bhigh) = A.bounds l - genericTake count l + genericTake count l | count > genericLength l = l | count <= 0 = empty | otherwise = A.listArray (blow, blow + (fromIntegral count) - 1) @@ -430,13 +493,15 @@ (L.genericDrop count (A.elems l)) where (blow, bhigh) = A.bounds l -- geneicSplitAt - genericReplicate count i = A.listArray (0, (fromIntegral count) - 1) + genericReplicate count i = A.listArray (0, (fromIntegral count) - 1) (L.genericReplicate count i) +instance (Integral i, Ix i) => IsString (A.Array i Char) where + fromString = fromList + instance (Integral i, Ix i) => StringLike (A.Array i Char) where toString = toList - fromString = fromList -- lines -- words @@ -477,7 +542,7 @@ instance StringLike (S.Seq Char) where toString = toList - fromString = fromList + --fromString = fromList instance FoldableLL (S.Seq a) a where foldl = F.foldl @@ -504,7 +569,7 @@ reverse = S.reverse --intersperse = --concat = - --concatMap = + --concatMap = --rigidConcatMap = any = F.any all = F.all @@ -543,9 +608,7 @@ --intersect = sort = S.sort --insert = S.insert - toList = F.toList - fromList = S.fromList - fromListLike = fromList . toList + --fromListLike = fromList . toList --nubBy = --deleteBy = --deleteFirstsBy = diff --git a/src/Data/ListLike/String.hs b/src/Data/ListLike/String.hs --- a/src/Data/ListLike/String.hs +++ b/src/Data/ListLike/String.hs @@ -12,8 +12,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable String-like functions @@ -21,11 +21,14 @@ Written by John Goerzen, jgoerzen\@complete.org -} +{-# LANGUAGE FlexibleContexts #-} + module Data.ListLike.String ( StringLike(..) + , fromString ) 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, @@ -35,20 +38,20 @@ unlines, unwords) import qualified Data.List as L import Data.ListLike.Base +import Data.String +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) {- | An extension to 'ListLike' for those data types that are similar to a 'String'. Minimal complete definition is 'toString' and 'fromString'. -} -class StringLike s where +class IsString s => StringLike s where {- | Converts the structure to a 'String' -} toString :: s -> String - - {- | Converts a 'String' to a list -} - fromString :: String -> s {- | Breaks a string into a list of strings -} lines :: (ListLike full s) => s -> full - --lines = map fromString . L.lines . toString + --lines = map fromString . L.lines . toString lines = myLines {- | Breaks a string into a list of words -} @@ -62,6 +65,22 @@ {- | Joins words -} unwords :: ListLike full s => full -> s unwords = myUnwords + + {- | Generalize the 'Show' method t return any 'StringLike'. -} + show :: Show a => a -> s + show = fromString . Prelude.show + + fromStringLike :: StringLike s' => s -> s' + fromStringLike = fromString . toString + + {- | Override this to avoid extra 'String' conversions. -} + fromText :: StringLike Text => Text -> s + fromText = fromString . toString + {- | Override this to avoid extra 'String' conversions. -} + fromLazyText :: StringLike Lazy.Text => Lazy.Text -> s + fromLazyText = fromString . toString + +{-# DEPRECATED fromStringLike "Use fromString . toString or something more efficient using local knowledge" #-} -- For some reason, Hugs required splitting these out into -- separate functions. diff --git a/src/Data/ListLike/Text.hs b/src/Data/ListLike/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Text.hs @@ -0,0 +1,7 @@ +module Data.ListLike.Text () + +where + +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 new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Text/Builder.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP + ,MultiParamTypeClasses + ,TypeFamilies + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Text.Builder + +where + +import Control.DeepSeq (NFData(rnf)) +import qualified Data.Text.Lazy.Builder as Builder +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.TextLazy () +--import Data.String (IsString(fromString)) +import GHC.Exts (IsList(..)) + +instance FoldableLL Builder.Builder Char where + foldl f r0 = LL.foldl f r0 . Builder.toLazyText + foldr f r0 = LL.foldr f r0 . Builder.toLazyText + +instance IsList Builder.Builder where + type Item Builder.Builder = Char + -- Can we do better? + toList = LL.toList' + fromList = LL.fromList' + +instance ListLike Builder.Builder Char where + singleton = Builder.singleton + uncons b = case LL.uncons (Builder.toLazyText b) of + Nothing -> Nothing + Just (c, s) -> Just (c, Builder.fromLazyText s) + null = LL.null . Builder.toLazyText + +instance ListLikeIO Builder.Builder Char where + hGetLine h = Builder.fromLazyText <$> hGetLine h + hGetContents h = Builder.fromLazyText <$> hGetContents h + hGet h n = Builder.fromLazyText <$> hGet h n + hGetNonBlocking h n = Builder.fromLazyText <$> hGetNonBlocking h n + hPutStr h = hPutStr h . Builder.toLazyText + +instance StringLike Builder.Builder where + toString = toString . Builder.toLazyText + fromText = Builder.fromText + fromLazyText = Builder.fromLazyText + +instance NFData Builder.Builder where + rnf = rnf . Builder.toLazyText diff --git a/src/Data/ListLike/Text/Text.hs b/src/Data/ListLike/Text/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Text/Text.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MultiParamTypeClasses + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Text.Text + +where + +import Prelude as P +import qualified Data.Text as T +import qualified Data.Text.IO as TI +import qualified Data.Text.Lazy as Lazy (toStrict) +import Data.Text.Encoding (decodeUtf8) +import Data.ListLike.Base as LL +import Data.ListLike.FoldableLL +import Data.ListLike.IO +import Data.ListLike.String + +import qualified Data.ByteString as BS + +instance FoldableLL T.Text Char where + foldl = T.foldl + foldl' = T.foldl' + foldl1 = T.foldl1 + foldr = T.foldr + --foldr' = T.foldr' + foldr1 = T.foldr1 + +instance ListLike T.Text Char where + empty = T.empty + singleton = T.singleton + cons = T.cons + snoc = T.snoc + append = T.append + head = T.head + last = T.last + tail = T.tail + init = T.init + null = T.null + length = T.length + rigidMap = T.map + reverse = T.reverse + intersperse = T.intersperse + concat = T.concat . toList + rigidConcatMap = T.concatMap + any = T.any + all = T.all + maximum = T.maximum + minimum = T.minimum + replicate n = T.replicate n . T.singleton + take = T.take + drop = T.drop + splitAt = T.splitAt + takeWhile = T.takeWhile + dropWhile = T.dropWhile + span = T.span + break = T.break + group = fromList . T.group + inits = fromList . T.inits + tails = fromList . T.tails + isPrefixOf = T.isPrefixOf + isSuffixOf = T.isSuffixOf + stripPrefix = T.stripPrefix + stripSuffix = T.stripSuffix + elem = T.isInfixOf . T.singleton + find = T.find + filter = T.filter + index = T.index + findIndex = T.findIndex + --toList = T.unpack + --fromList = T.pack + --fromListLike = fromList . toList + groupBy f = fromList . T.groupBy f + genericLength = fromInteger . fromIntegral . T.length + genericTake i = T.take (fromIntegral i) + genericDrop i = T.drop (fromIntegral i) + genericSplitAt i = T.splitAt (fromIntegral i) + genericReplicate i = LL.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance ListLikeIO T.Text Char where + hGetLine = TI.hGetLine + hGetContents = TI.hGetContents + hGet h c = BS.hGet h c >>= return . decodeUtf8 + hGetNonBlocking h i = BS.hGetNonBlocking h i >>= return . decodeUtf8 + hPutStr = TI.hPutStr + hPutStrLn = TI.hPutStrLn + getLine = TI.getLine + getContents = TI.getContents + putStr = TI.putStr + putStrLn = TI.putStrLn + interact = TI.interact + readFile = TI.readFile + writeFile = TI.writeFile + appendFile = TI.appendFile + +instance StringLike T.Text where + toString = T.unpack + words = fromList . T.words + lines = fromList . T.lines + unwords = T.unwords . toList + unlines = T.unlines . toList + + fromText = id + fromLazyText = Lazy.toStrict diff --git a/src/Data/ListLike/Text/TextLazy.hs b/src/Data/ListLike/Text/TextLazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Text/TextLazy.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Text.TextLazy + +where + +import Prelude as P +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as TI +import Data.Text.Encoding (decodeUtf8) +import Data.ListLike.Base as LL +import Data.ListLike.FoldableLL +import Data.ListLike.IO +import Data.ListLike.String + +import qualified Data.ByteString as BS + +instance FoldableLL T.Text Char where + foldl = T.foldl + foldl' = T.foldl' + foldl1 = T.foldl1 + foldr = T.foldr + foldr1 = T.foldr1 + +instance ListLike T.Text Char where + empty = T.empty + singleton = T.singleton + cons = T.cons + snoc = T.snoc + append = T.append + head = T.head + last = T.last + tail = T.tail + init = T.init + null = T.null + length = fromIntegral . T.length + rigidMap = T.map + reverse = T.reverse + intersperse = T.intersperse + concat = T.concat . toList + rigidConcatMap = T.concatMap + any = T.any + all = T.all + maximum = T.maximum + minimum = T.minimum + replicate n = T.replicate (fromIntegral n) . T.singleton + take = T.take . fromIntegral + drop = T.drop . fromIntegral + splitAt = T.splitAt . fromIntegral + takeWhile = T.takeWhile + dropWhile = T.dropWhile + span = T.span + break = T.break + group = fromList . T.group + inits = fromList . T.inits + tails = fromList . T.tails + isPrefixOf = T.isPrefixOf + isSuffixOf = T.isSuffixOf + stripPrefix = T.stripPrefix + stripSuffix = T.stripSuffix + elem = T.isInfixOf . T.singleton + find = T.find + filter = T.filter + index t = T.index t . fromIntegral + --toList = T.unpack + --fromList = T.pack + --fromListLike = fromList . toList + groupBy f = fromList . T.groupBy f + genericLength = fromInteger . fromIntegral . T.length + genericTake i = T.take (fromIntegral i) + genericDrop i = T.drop (fromIntegral i) + genericSplitAt i = T.splitAt (fromIntegral i) + genericReplicate i = LL.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance ListLikeIO T.Text Char where + hGetLine = TI.hGetLine + hGetContents = TI.hGetContents + hGet h = fmap (T.fromStrict . decodeUtf8) . BS.hGet h + hGetNonBlocking h = fmap (T.fromStrict . decodeUtf8) . BS.hGetNonBlocking h + hPutStr = TI.hPutStr + hPutStrLn = TI.hPutStrLn + getLine = TI.getLine + getContents = TI.getContents + putStr = TI.putStr + putStrLn = TI.putStrLn + interact = TI.interact + readFile = TI.readFile + writeFile = TI.writeFile + appendFile = TI.appendFile + +instance StringLike T.Text where + toString = T.unpack + words = fromList . T.words + lines = fromList . T.lines + unwords = T.unwords . toList + unlines = T.unlines . toList + + fromText = T.fromStrict + fromLazyText = id diff --git a/src/Data/ListLike/UTF8.hs b/src/Data/ListLike/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/UTF8.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE CPP + ,MultiParamTypeClasses + ,FlexibleInstances + ,TypeFamilies + ,TypeSynonymInstances + ,UndecidableInstances #-} +{-# OPTIONS -Wno-orphans #-} + +{- | +Instances of 'Data.ListLike.ListLike' and related classes. +Re-exported by "Data.ListLike". +-} + +-------------------------------------------------- +-- UTF8 ByteString + +module Data.ListLike.UTF8 () where + +import qualified Data.ByteString as BS +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 Data.ListLike.Base as LL +import Data.ListLike.FoldableLL +import Data.ListLike.IO +import Data.ListLike.String (StringLike(..)) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif +#if !MIN_VERSION_utf8_string(1,0,2) +import Data.String (IsString(fromString)) +#endif +import Data.String.UTF8 (UTF8{-, UTF8Bytes-}) +import qualified Data.String.UTF8 as UTF8 +import GHC.Exts (IsList(..)) +--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 + -- foldl' = UTF8.foldl' + -- foldl1 = UTF8.foldl1 + foldr = UTF8.foldr + -- foldr' = UTF8.foldr' + -- foldr1 = UTF8.foldr1 + +instance IsList (UTF8 BS.ByteString) where + type Item (UTF8 BS.ByteString) = Char + toList = UTF8.toString + fromList = LL.fromList' -- LL.map id + +instance ListLike (UTF8 BS.ByteString) Char where + empty = mempty + singleton c = UTF8.fromString [c] + -- cons = UTF8.cons + -- snoc = UTF8.snoc + -- append = UTF8.append + uncons = UTF8.uncons + head = fst . fromMaybe (error "head") . uncons + -- last = UTF8.last + tail = snd . fromMaybe (error "tail") . uncons + -- init = UTF8.init + null s = UTF8.length s == 0 + length = UTF8.length + -- -- map = + -- rigidMap = UTF8.map + -- reverse = UTF8.reverse + -- intersperse = UTF8.intersperse + -- concat = UTF8.concat . toList + -- --concatMap = + -- rigidConcatMap = UTF8.concatMap + -- any = UTF8.any + -- all = UTF8.all + -- maximum = UTF8.maximum + -- minimum = UTF8.minimum + -- replicate = UTF8.replicate + take = UTF8.take + drop = UTF8.drop + splitAt = UTF8.splitAt + -- takeWhile = UTF8.takeWhile + -- dropWhile = UTF8.dropWhile + span = UTF8.span + break = UTF8.break + -- group = fromList . UTF8.group + -- inits = fromList . UTF8.inits + -- tails = fromList . UTF8.tails + -- isPrefixOf = UTF8.isPrefixOf + -- isSuffixOf = UTF8.isSuffixOf + -- --isInfixOf = UTF8.isInfixOf + -- elem = UTF8.elem + -- notElem = UTF8.notElem + -- find = UTF8.find + -- filter = UTF8.filter + -- --partition = UTF8.partition + -- index = UTF8.index + -- elemIndex = UTF8.elemIndex + -- elemIndices x = fromList . UTF8.elemIndices x + -- findIndex = UTF8.findIndex + -- findIndices x = fromList . UTF8.findIndices x + -- -- the default definitions don't work well for array-like things, so + -- -- do monadic stuff via a list instead + -- sequence = fmap fromList . P.sequenceA . toList + -- mapM func = fmap fromList . P.traverse func . toList + -- --nub = UTF8.nub + -- --delete = UTF8.delete + -- --deleteFirsts = UTF8.deleteFirsts + -- --union = UTF8.union + -- --intersect = UTF8.intersect + -- sort = UTF8.sort + -- --insert = UTF8.insert + --toList = UTF8.toString + -- fromList = UTF8.pack + -- fromListLike = fromList . toList + -- --nubBy = UTF8.nubBy + -- --deleteBy = UTF8.deleteBy + -- --deleteFirstsBy = UTF8.deleteFirstsBy + -- --unionBy = UTF8.unionBy + -- --intersectBy = UTF8.intersectBy + -- groupBy f = fromList . UTF8.groupBy f + -- --sortBy = UTF8.sortBy + -- --insertBy = UTF8.insertBy + -- genericLength = fromInteger . fromIntegral . UTF8.length + -- genericTake i = UTF8.take (fromIntegral i) + -- genericDrop i = UTF8.drop (fromIntegral i) + -- genericSplitAt i = UTF8.splitAt (fromIntegral i) + -- genericReplicate i = UTF8.replicate (fromIntegral i) + +instance ListLikeIO (UTF8 BS.ByteString) Char where + hGetLine h = UTF8.fromRep <$> BSC.hGetLine h + hGetContents h = UTF8.fromRep <$> BS.hGetContents h + hGet h n = UTF8.fromRep <$> BS.hGet h n + hGetNonBlocking h n = UTF8.fromRep <$> BS.hGetNonBlocking h n + hPutStr h s = BS.hPutStr h (UTF8.toRep s) + hPutStrLn h s = BSC.hPutStrLn h (UTF8.toRep s) + -- getLine = BS.getLine + -- getContents = BS.getContents + -- putStr = BS.putStr + -- putStrLn = BSC.putStrLn + -- interact = BS.interact + -- readFile = BS.readFile + -- writeFile = BS.writeFile + -- appendFile = BS.appendFile + +#if !MIN_VERSION_utf8_string(1,0,2) +instance IsString (UTF8 BS.ByteString) where + fromString = UTF8.fromString +#endif + +instance StringLike (UTF8 BS.ByteString) where + toString = UTF8.toString + +instance Semigroup (UTF8 BS.ByteString) where + a <> b = UTF8.fromRep $ UTF8.toRep a <> UTF8.toRep b + +instance Monoid (UTF8 BS.ByteString) where + mempty = UTF8.fromString [] + mappend = (<>) + +-------------------------------------------------- +-- UTF8 Lazy.ByteString + +instance FoldableLL (UTF8 BSL.ByteString) Char where + foldl = UTF8.foldl + -- foldl' = UTF8.foldl' + -- foldl1 = UTF8.foldl1 + foldr = UTF8.foldr + -- foldr' = UTF8.foldr' + -- foldr1 = UTF8.foldr1 + +instance IsList (UTF8 BSL.ByteString) where + type Item (UTF8 BSL.ByteString) = Char + toList = UTF8.toString + fromList = LL.fromList' -- LL.map id + +instance ListLike (UTF8 BSL.ByteString) Char where + empty = mempty + singleton c = UTF8.fromString [c] + -- cons = UTF8.cons + -- snoc = UTF8.snoc + -- append = UTF8.append + uncons = UTF8.uncons + head = fst . fromMaybe (error "head") . uncons + -- last = UTF8.last + tail = snd . fromMaybe (error "tail") . uncons + -- init = UTF8.init + null s = UTF8.length s == 0 + length = fromInteger . toInteger . UTF8.length + -- -- map = + -- rigidMap = UTF8.map + -- reverse = UTF8.reverse + -- intersperse = UTF8.intersperse + -- concat = UTF8.concat . toList + -- --concatMap = + -- rigidConcatMap = UTF8.concatMap + -- any = UTF8.any + -- all = UTF8.all + -- maximum = UTF8.maximum + -- minimum = UTF8.minimum + -- replicate = UTF8.replicate + take = UTF8.take . fromInteger . toInteger + drop = UTF8.drop . fromInteger . toInteger + splitAt = UTF8.splitAt . fromInteger . toInteger + -- takeWhile = UTF8.takeWhile + -- dropWhile = UTF8.dropWhile + span = UTF8.span + break = UTF8.break + -- group = fromList . UTF8.group + -- inits = fromList . UTF8.inits + -- tails = fromList . UTF8.tails + -- isPrefixOf = UTF8.isPrefixOf + -- isSuffixOf = UTF8.isSuffixOf + -- --isInfixOf = UTF8.isInfixOf + -- elem = UTF8.elem + -- notElem = UTF8.notElem + -- find = UTF8.find + -- filter = UTF8.filter + -- --partition = UTF8.partition + -- index = UTF8.index + -- elemIndex = UTF8.elemIndex + -- elemIndices x = fromList . UTF8.elemIndices x + -- findIndex = UTF8.findIndex + -- findIndices x = fromList . UTF8.findIndices x + -- -- the default definitions don't work well for array-like things, so + -- -- do monadic stuff via a list instead + -- sequence = fmap fromList . P.sequenceA . toList + -- mapM func = fmap fromList . P.traverse func . toList + -- --nub = UTF8.nub + -- --delete = UTF8.delete + -- --deleteFirsts = UTF8.deleteFirsts + -- --union = UTF8.union + -- --intersect = UTF8.intersect + -- sort = UTF8.sort + -- --insert = UTF8.insert + -- toList = UTF8.toString + -- fromList = UTF8.pack + -- fromListLike = fromList . toList + -- --nubBy = UTF8.nubBy + -- --deleteBy = UTF8.deleteBy + -- --deleteFirstsBy = UTF8.deleteFirstsBy + -- --unionBy = UTF8.unionBy + -- --intersectBy = UTF8.intersectBy + -- groupBy f = fromList . UTF8.groupBy f + -- --sortBy = UTF8.sortBy + -- --insertBy = UTF8.insertBy + -- genericLength = fromInteger . fromIntegral . UTF8.length + -- genericTake i = UTF8.take (fromIntegral i) + -- genericDrop i = UTF8.drop (fromIntegral i) + -- genericSplitAt i = UTF8.splitAt (fromIntegral i) + -- genericReplicate i = UTF8.replicate (fromIntegral i) + +instance ListLikeIO (UTF8 BSL.ByteString) Char where + hGetLine h = (UTF8.fromRep . BSL.fromStrict) <$> BSC.hGetLine h + hGetContents h = (UTF8.fromRep) <$> BSL.hGetContents h + hGet h n = UTF8.fromRep <$> BSL.hGet h n + hGetNonBlocking h n = UTF8.fromRep <$> BSL.hGetNonBlocking h n + hPutStr h s = BSL.hPutStr h (UTF8.toRep s) + hPutStrLn h s = BSLC.hPutStrLn h (UTF8.toRep s) + -- getLine = BSL.getLine + -- getContents = BSL.getContents + -- putStr = BSL.putStr + -- putStrLn = BSLC.putStrLn + -- interact = BSL.interact + -- readFile = BSL.readFile + -- writeFile = BSL.writeFile + -- appendFile = BSL.appendFile + +#if !MIN_VERSION_utf8_string(1,0,2) +instance IsString (UTF8 BSL.ByteString) where + fromString = UTF8.fromString +#endif + +instance StringLike (UTF8 BSL.ByteString) where + toString = UTF8.toString + +instance Semigroup (UTF8 BSL.ByteString) where + a <> b = UTF8.fromRep $ UTF8.toRep a <> UTF8.toRep b + +instance Monoid (UTF8 BSL.ByteString) where + mempty = UTF8.fromString [] + mappend = (<>) + +{-# RULES "fromListLike/a" fromListLike = id :: a -> a #-} 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 @@ -15,8 +15,8 @@ Copyright : Copyright (C) 2007 John Goerzen License : BSD3 - Maintainer : John Lato - Stability : provisional + Maintainer : David Fox , Andreas Abel + Stability : stable Portability: portable Utilities for 'Data.ListLike.ListLike' and friends. More functions @@ -26,20 +26,20 @@ -} module Data.ListLike.Utils - (and, or, sum, product, zip, zipWith, unzip, sequence_, toMonadPlus, list + (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, sequence_, mapM, mapM_, concatMap, and, or, sum, product, repeat, replicate, cycle, take, drop, splitAt, elem, notElem, unzip, lines, words, - unlines, unwords) + unlines, unwords, foldMap) import Control.Monad (MonadPlus(..)) import Data.ListLike.Base import Data.ListLike.FoldableLL -import Data.Maybe (maybe) import Data.Monoid -- | Returns True if all elements are True @@ -69,10 +69,15 @@ -- | Converts to a MonadPlus instance toMonadPlus :: (MonadPlus m, ListLike full a) => full -> m (a, full) -toMonadPlus c - | null c = mzero - | otherwise = return (head c, tail c) +toMonadPlus = maybe mzero return . uncons -- | List-like destructor (like Data.Maybe.maybe) list :: ListLike full a => b -> (a -> full -> b) -> full -> b list d f = maybe d (uncurry f) . toMonadPlus + +-- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' +-- xs xss))@. It inserts the list @xs@ in between the lists in @xss@ +-- and concatenates the result. +intercalate :: (ListLike a item, ListLike b a) + => a -> b -> a +intercalate x = concat . intersperse x diff --git a/src/Data/ListLike/Vector.hs b/src/Data/ListLike/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Vector.hs @@ -0,0 +1,11 @@ +-- | 'Data.ListLike.ListLike' instances for several @Data.Vector@ types. +-- The @Data.ListLike.Vector.Generic@ instances are not exported from this +-- module in order to prevent collisions. +-- +module Data.ListLike.Vector () + +where + +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 new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Vector/Generic.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} -- for GHC >= 9.4 + +{-# OPTIONS -Wno-orphans #-} + +-- | ListLike instance for any type supporting the @Data.Vector.Generic@ +-- interface. To avoid collisions with other Vector instances, this module +-- must be imported directly. +module Data.ListLike.Vector.Generic () + +where + +import Prelude as P +import qualified Data.Vector.Generic as V +import Data.Vector.Generic ((!)) +import Data.ListLike.Base +import Data.ListLike.FoldableLL +import Data.ListLike.String +import Data.String (IsString) +import GHC.Exts (IsList(..)) + +instance {-# OVERLAPPABLE #-} V.Vector v a => FoldableLL (v a) a where + foldl = V.foldl + foldl' = V.foldl' + foldl1 = V.foldl1 + foldr = V.foldr + foldr' = V.foldr' + foldr1 = V.foldr1 + +#if 0 +instance {-# OVERLAPPABLE #-} (Monoid (v a), Eq (v a), V.Vector v a) => IsList (v a) where + type Item (v a) = a + toList = V.toList + fromList = V.fromList +#endif + +instance {-# OVERLAPPABLE #-} (IsList (v a), Item (v a) ~ a, Monoid (v a), Eq (v a), V.Vector v a) => ListLike (v a) a where + empty = V.empty + singleton = V.singleton + cons = V.cons + snoc = V.snoc + append = mappend + head = V.head + last = V.last + tail = V.tail + init = V.init + null = V.null + length = V.length + rigidMap = V.map + reverse = V.reverse + --intersperse = + concat = V.concat . toList + rigidConcatMap = V.concatMap + any = V.any + all = V.all + maximum = V.maximum + minimum = V.minimum + replicate = V.replicate + take = V.take + drop = V.drop + --splitAt = + takeWhile = V.takeWhile + dropWhile = V.dropWhile + span = V.span + break = V.break + --group = + --inits = + --tails = + isPrefixOf = isPrefixOf' + isSuffixOf = isSuffixOf' + elem = V.elem + find = V.find + filter = V.filter + index = (!) + findIndex = V.findIndex + --toList = V.toList + --fromList = V.fromList + --fromListLike = fromList . toList + --groupBy f = + genericLength = fromInteger . fromIntegral . V.length + genericTake i = V.take (fromIntegral i) + genericDrop i = V.drop (fromIntegral i) + --genericSplitAt i = + genericReplicate i = V.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance (Eq (v Char), V.Vector v Char) => IsString (v Char) where + fromString = V.fromList + +instance (Eq (v Char), V.Vector v Char) => StringLike (v Char) where + toString = V.toList + --words = + --lines = + 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 = + needle == V.slice (V.length haystack - V.length needle) + (V.length needle) + haystack + | V.length needle == V.length haystack = needle == haystack + | otherwise = False diff --git a/src/Data/ListLike/Vector/Storable.hs b/src/Data/ListLike/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Vector/Storable.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Vector.Storable () + +where + +import Prelude as P +import qualified Data.Vector.Storable as V +import Data.Vector.Storable ((!)) +import Data.ListLike.Base +import Data.ListLike.FoldableLL +import Data.ListLike.String +import Data.String (IsString) + +import Foreign.Storable (Storable) + + +instance Storable a => FoldableLL (V.Vector a) a where + foldl = V.foldl + foldl' = V.foldl' + foldl1 = V.foldl1 + foldr = V.foldr + foldr' = V.foldr' + foldr1 = V.foldr1 + +instance Storable a => ListLike (V.Vector a) a where + empty = V.empty + singleton = V.singleton + cons = V.cons + snoc = V.snoc + append = mappend + head = V.head + last = V.last + tail = V.tail + init = V.init + null = V.null + length = V.length + rigidMap = V.map + reverse = V.reverse + --intersperse = + concat = V.concat . toList + rigidConcatMap = V.concatMap + any = V.any + all = V.all + maximum = V.maximum + minimum = V.minimum + replicate = V.replicate + take = V.take + drop = V.drop + --splitAt = + takeWhile = V.takeWhile + dropWhile = V.dropWhile + span = V.span + break = V.break + --group = + --inits = + --tails = + isPrefixOf = isPrefixOf' + isSuffixOf = isSuffixOf' + elem = V.elem + find = V.find + filter = V.filter + index = (!) + findIndex = V.findIndex + --toList = V.toList + --fromList = V.fromList + --fromListLike = fromList . toList + --groupBy f = + genericLength = fromInteger . fromIntegral . V.length + genericTake i = V.take (fromIntegral i) + genericDrop i = V.drop (fromIntegral i) + --genericSplitAt i = + genericReplicate i = V.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance IsString (V.Vector Char) where + fromString = fromList + +instance StringLike (V.Vector Char) where + toString = toList + --words = + --lines = + 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 = + needle == V.slice (V.length haystack - V.length needle) + (V.length needle) + haystack + | V.length needle == V.length haystack = needle == haystack + | otherwise = False diff --git a/src/Data/ListLike/Vector/Unboxed.hs b/src/Data/ListLike/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Vector/Unboxed.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Vector.Unboxed () + +where + +import Prelude as P +import qualified Data.Vector.Unboxed as V +import Data.Vector.Unboxed (Unbox, (!)) +import Data.ListLike.Base +import Data.ListLike.FoldableLL +import Data.ListLike.String +import Data.String (IsString) + + +instance Unbox a => FoldableLL (V.Vector a) a where + foldl = V.foldl + foldl' = V.foldl' + foldl1 = V.foldl1 + foldr = V.foldr + foldr' = V.foldr' + foldr1 = V.foldr1 + +instance Unbox a => ListLike (V.Vector a) a where + empty = V.empty + singleton = V.singleton + cons = V.cons + snoc = V.snoc + append = mappend + head = V.head + last = V.last + tail = V.tail + init = V.init + null = V.null + length = V.length + rigidMap = V.map + reverse = V.reverse + --intersperse = + concat = V.concat . toList + rigidConcatMap = V.concatMap + any = V.any + all = V.all + maximum = V.maximum + minimum = V.minimum + replicate = V.replicate + take = V.take + drop = V.drop + --splitAt = + takeWhile = V.takeWhile + dropWhile = V.dropWhile + span = V.span + break = V.break + --group = + --inits = + --tails = + isPrefixOf = isPrefixOf' + isSuffixOf = isSuffixOf' + elem = V.elem + find = V.find + filter = V.filter + index = (!) + findIndex = V.findIndex + --toList = V.toList + --fromList = V.fromList + --fromListLike = fromList . toList + --groupBy f = + genericLength = fromInteger . fromIntegral . V.length + genericTake i = V.take (fromIntegral i) + genericDrop i = V.drop (fromIntegral i) + --genericSplitAt i = + genericReplicate i = V.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance IsString (V.Vector Char) where + fromString = fromList + +instance StringLike (V.Vector Char) where + toString = toList + --words = + --lines = + 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 = + needle == V.slice (V.length haystack - V.length needle) + (V.length needle) + haystack + | V.length needle == V.length haystack = needle == haystack + | otherwise = False diff --git a/src/Data/ListLike/Vector/Vector.hs b/src/Data/ListLike/Vector/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/ListLike/Vector/Vector.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies + ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} + +module Data.ListLike.Vector.Vector () + +where + +import Prelude as P +import qualified Data.Vector as V +import Data.Vector ((!)) +import Data.ListLike.Base +import Data.ListLike.FoldableLL +import Data.ListLike.String +import Data.String (IsString) + +instance FoldableLL (V.Vector a) a where + foldl = V.foldl + foldl' = V.foldl' + foldl1 = V.foldl1 + foldr = V.foldr + foldr' = V.foldr' + foldr1 = V.foldr1 + +instance ListLike (V.Vector a) a where + empty = V.empty + singleton = V.singleton + cons = V.cons + snoc = V.snoc + append = mappend + head = V.head + last = V.last + tail = V.tail + init = V.init + null = V.null + length = V.length + rigidMap = V.map + reverse = V.reverse + --intersperse = + concat = V.concat . toList + rigidConcatMap = V.concatMap + any = V.any + all = V.all + maximum = V.maximum + minimum = V.minimum + replicate = V.replicate + take = V.take + drop = V.drop + --splitAt = + takeWhile = V.takeWhile + dropWhile = V.dropWhile + span = V.span + break = V.break + --group = + --inits = + --tails = + isPrefixOf = isPrefixOf' + isSuffixOf = isSuffixOf' + elem = V.elem + find = V.find + filter = V.filter + index = (!) + findIndex = V.findIndex + --toList = V.toList + --fromList = V.fromList + --fromListLike = fromList . toList + --groupBy f = + genericLength = fromInteger . fromIntegral . V.length + genericTake i = V.take (fromIntegral i) + genericDrop i = V.drop (fromIntegral i) + --genericSplitAt i = + genericReplicate i = V.replicate (fromIntegral i) + + sequence = fmap fromList . P.sequenceA . toList + mapM func = fmap fromList . P.traverse func . toList + +instance IsString (V.Vector Char) where + fromString = fromList + +instance StringLike (V.Vector Char) where + toString = toList + --words = + --lines = + 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 = + needle == V.slice (V.length haystack - V.length needle) + (V.length needle) + haystack + | V.length needle == V.length haystack = needle == haystack + | otherwise = False diff --git a/testsrc/TestInfrastructure.hs b/testsrc/TestInfrastructure.hs new file mode 100644 --- /dev/null +++ b/testsrc/TestInfrastructure.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE CPP + ,ScopedTypeVariables + ,RankNTypes + ,ExistentialQuantification + ,MultiParamTypeClasses + ,FunctionalDependencies + ,FlexibleInstances + ,UndecidableInstances + ,TypeFamilies + ,FlexibleContexts #-} +{-# OPTIONS -Wno-orphans #-} + +{- +Copyright (C) 2007 John Goerzen + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-- FIXME -- better code is in offlineimap v7 branch +module TestInfrastructure where + +import Test.QuickCheck +import Test.QuickCheck.Test +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ListLike as LL +import qualified Data.ListLike.Chars as Chars +import qualified Data.Array as A +import qualified Data.DList as DL +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.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.String.UTF8 as UTF8 +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.IO +import qualified Test.HUnit as HU +import Text.Printf +import Data.Function (on) +import Data.String (IsString(fromString)) +import Data.Word +import Data.List +import Data.Monoid (Monoid(..)) +import GHC.Exts (IsList(Item)) + +simpleArb :: (LL.ListLike f i, Arbitrary i) => Gen f +simpleArb = sized (\n -> choose (0, n) >>= myVector) + where myVector n = do + arblist <- vector n + return (LL.fromList arblist) + +instance (Arbitrary i) => Arbitrary (MyList i) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink (MyList l) = map MyList $ shrink l + +instance (CoArbitrary i) => CoArbitrary (MyList i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance (Arbitrary i) => Arbitrary (DL.DList i) where + arbitrary = simpleArb + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i) => CoArbitrary (DL.DList i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance (Arbitrary i) => Arbitrary (FM.FMList i) where + arbitrary = simpleArb + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i) => CoArbitrary (FM.FMList i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (BSL.ByteString) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (BSL.ByteString) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (BS.ByteString) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (BS.ByteString) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary Chars.Chars where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary Chars.Chars where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary i => Arbitrary (A.Array Int i) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i) => CoArbitrary (A.Array Int i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (T.Text) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (T.Text) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (TL.Text) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (TL.Text) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (TB.Builder) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (TB.Builder) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (UTF8.UTF8 BS.ByteString) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (UTF8.UTF8 BS.ByteString) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary (UTF8.UTF8 BSL.ByteString) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance CoArbitrary (UTF8.UTF8 BSL.ByteString) where + coarbitrary l = coarbitrary (LL.toList l) + +instance Arbitrary i => Arbitrary (V.Vector i) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i) => CoArbitrary (V.Vector i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance (Arbitrary i, VS.Storable i) => Arbitrary (VS.Vector i) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i, VS.Storable i) => CoArbitrary (VS.Vector i) where + coarbitrary l = coarbitrary (LL.toList l) + +instance (Arbitrary i, VU.Unbox i) => Arbitrary (VU.Vector i) where + arbitrary = sized (\n -> choose (0, n) >>= myVector) + where myVector n = + do arblist <- vector n + return (LL.fromList arblist) + shrink = map LL.fromList . shrink . LL.toList + +instance (CoArbitrary i, VU.Unbox i) => CoArbitrary (VU.Vector i) where + coarbitrary l = coarbitrary (LL.toList l) + +class (Show b, Arbitrary a, Show a, Eq a, Eq b, LL.ListLike a b) => TestLL a b where + llcmp :: a -> [b] -> Property + llcmp f l = (putStrLn ("Expected: " ++ show l ++ "\nGot: " ++ show f)) + `whenFail` (l == (LL.toList f)) + checkLengths :: a -> [b] -> Bool + checkLengths f l = (LL.length f) == length l + +instance (Arbitrary a, Show a, Eq a) => TestLL [a] a where + +instance (Arbitrary a, Show a, Eq a) => TestLL (MyList a) a + +instance (Arbitrary a, Show a, Eq a) => TestLL (DL.DList a) a + +instance (Arbitrary a, Show a, Eq a) => TestLL (FM.FMList a) a + +instance TestLL BS.ByteString Word8 where + +instance TestLL BSL.ByteString Word8 where + +instance TestLL Chars.Chars Char where + +instance (Arbitrary a, Show a, Eq a) => TestLL (S.Seq a) a where + +instance (Arbitrary a, Show a, Eq a) => TestLL (A.Array Int a) a where + +instance TestLL T.Text Char where + +instance TestLL TL.Text Char where + +instance TestLL TB.Builder Char where + +instance TestLL (UTF8.UTF8 BS.ByteString) Char where + +instance TestLL (UTF8.UTF8 BSL.ByteString) Char where + +instance (Arbitrary a, Show a, Eq a) => TestLL (V.Vector a) a where + +instance (Arbitrary a, Show a, Eq a, VS.Storable a) => TestLL (VS.Vector a) a where + +instance (Arbitrary a, Show a, Eq a, VU.Unbox a) => TestLL (VU.Vector a) a where + +instance Eq a => Eq (FM.FMList a) where + (==) = (==) `on` FM.toList + +mapRemoveDups :: (Eq k1) => [(k1, v1)] -> [(k1, v1)] +mapRemoveDups = nubBy (\(k1, _) (k2, _) -> k1 == k2) + +data MyList a = MyList [a] + deriving (Ord, Eq, Show) + +instance LL.FoldableLL (MyList a) a where + foldr f i (MyList x) = foldr f i x + foldl f i (MyList x) = foldl f i x + foldr1 f (MyList x) = foldr1 f x + foldl1 f (MyList x) = foldl1 f x + +instance Sem.Semigroup (MyList a) where + MyList x <> MyList y = MyList (x ++ y) + +instance Monoid (MyList a) where + mempty = MyList [] + mappend = (Sem.<>) + +instance IsList (MyList a) where + type Item (MyList a) = a + toList (MyList xs) = xs + fromList = MyList + +instance LL.ListLike (MyList a) a where + singleton x = MyList [x] + -- Andreas Abel, 2023-10-10, issue #32: + -- Avoid 'head' and 'tail' from 'Prelude' and thus the x-partial warning of GHC 9.8. + head (MyList (x:xs)) = x + head (MyList []) = undefined + tail (MyList (x:xs)) = MyList xs + tail (MyList [] ) = undefined + null (MyList x) = null x + +instance IsString (MyList Char) where + fromString = MyList + +instance LL.StringLike (MyList Char) where + toString (MyList x) = x + +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) 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' + reportError = reportProblem "Error:" "Error in: " + reportFailure = reportProblem "Failure:" "Failure in: " + reportProblem p0 p1 _mloc msg ss us' = put line True us' + where line = "### " ++ kind ++ path' ++ '\n' : msg + kind = if null path' then p0 else p1 + path' = HU.showPath (HU.path ss) + + +-- | So we can test map and friends +instance Show (a -> b) where + show _ = "(a -> b)" + +data LLTest f i = + forall t. Testable t => LLTest (f -> t) + +data LLWrap f' f i = + forall t. Testable t => LLWrap (f' -> t) + +w :: TestLL f i => String -> LLTest f i -> HU.Test +w msg (LLTest theTest) = mkTest msg theTest + +ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test +ws = w + +wwrap :: (TestLL f i, TestLL f' f) => String -> LLWrap f' f i -> HU.Test +wwrap msg f = case f of + LLWrap theTest -> mkTest msg theTest + +t :: forall f t i. (TestLL f i, Arbitrary f, Arbitrary i, Show f, Eq f, Testable t) => (f -> t) -> LLTest f i +t = LLTest + +-- | all props, wrapped list +apw :: String -> (forall f' f i. (TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, LL.ListLike f' f, Show f', TestLL f' f, Arbitrary f', Eq f') => LLWrap f' f i) -> HU.Test +apw msg x = HU.TestLabel msg $ HU.TestList $ + [wwrap "wrap [[Int]]" (x::LLWrap [[Int]] [Int] Int), + wwrap "wrap MyList (MyList Int)" (x::LLWrap (MyList (MyList Int)) (MyList Int) Int), + wwrap "wrap S.Seq (S.Seq Int)" (x::LLWrap (S.Seq (S.Seq Int)) (S.Seq Int) Int), + wwrap "wrap Array (Array Int)" (x::LLWrap (A.Array Int (A.Array Int Int)) (A.Array Int Int) Int), + wwrap "wrap Array [Int]" (x::LLWrap (A.Array Int [Int]) [Int] Int) + ,wwrap "wrap (Vector (Vector Int))" (x::LLWrap (V.Vector (V.Vector Int)) (V.Vector Int) Int) + ] + +-- | 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 msg x = HU.TestLabel msg $ HU.TestList $ + [w "[Int]" (x::LLTest [Int] Int), + w "MyList Int" (x::LLTest (MyList Int) Int), + w "String" (x::LLTest String Char), + w "[Bool]" (x::LLTest [Bool] Bool), + w "MyList Bool" (x::LLTest (MyList Bool) Bool), + w "ByteString" (x::LLTest BS.ByteString Word8), + w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8), + w "Chars" (x::LLTest Chars.Chars Char), + w "Sequence Int" (x::LLTest (S.Seq Int) Int), + w "Sequence Bool" (x::LLTest (S.Seq Bool) Bool), + w "Sequence Char" (x::LLTest (S.Seq Char) Char), + w "Array Int Int" (x::LLTest (A.Array Int Int) Int), + w "Array Int Bool" (x::LLTest (A.Array Int Bool) Bool), + w "Array (Just Int)" (x::LLTest (A.Array Int (Maybe Int)) (Maybe Int)), + w "DList Int" (x::LLTest (DL.DList Int) Int), + -- w "FMList Int" (x::LLTest (FM.FMList Int) Int), + w "Vector Int" (x::LLTest (V.Vector Int) Int), + w "StorableVector Int" (x::LLTest (VS.Vector Int) Int), + w "UnboxVector Int" (x::LLTest (VU.Vector Int) Int), + w "Vector Bool" (x::LLTest (V.Vector Bool) Bool), + w "StorableVector Bool" (x::LLTest (VS.Vector Bool) Bool), + w "UnboxVector Bool" (x::LLTest (VU.Vector Bool) Bool), + w "Text" (x::LLTest T.Text Char), + w "Text.Lazy" (x::LLTest TL.Text Char), + w "Text.Builder" (x::LLTest TB.Builder Char), + w "UTF8 ByteString" (x::LLTest (UTF8.UTF8 BS.ByteString) Char), + w "UTF8 ByteString.Lazy" (x::LLTest (UTF8.UTF8 BSL.ByteString) Char) + ] + +-- | 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 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 "Chars" (x::LLTest Chars.Chars Char), + w "Array Int Char" (x::LLTest (A.Array Int Char) Char), + w "Text" (x::LLTest T.Text Char), + w "Text.Lazy" (x::LLTest TL.Text Char), + w "Text.Builder" (x::LLTest TB.Builder Char), + w "UTF8 ByteString" (x::LLTest (UTF8.UTF8 BS.ByteString) Char), + w "UTF8 ByteString.Lazy" (x::LLTest (UTF8.UTF8 BSL.ByteString) Char), + w "Vector Char" (x::LLTest (V.Vector Char) Char), + w "Vector.Unbox Char" (x::LLTest (VU.Vector Char) Char) + ] diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs --- a/testsrc/runtests.hs +++ b/testsrc/runtests.hs @@ -1,12 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables - ,RankNTypes - ,ExistentialQuantification - ,MultiParamTypeClasses - ,FunctionalDependencies - ,FlexibleInstances - ,UndecidableInstances - ,FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wno-missing-signatures #-} + + {- Copyright (C) 2007 John Goerzen @@ -17,18 +23,20 @@ -} module Main where +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 @@ -39,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 @@ -49,9 +57,17 @@ prop_cons f i = llcmp (LL.cons i f) (i : (LL.toList f)) prop_append f1 f2 = llcmp (LL.append f1 f2) (LL.toList f1 ++ LL.toList f2) prop_head f = not (LL.null f) ==> LL.head f == head (LL.toList f) -prop_last f = not (LL.null f) ==> LL.last f == last (LL.toList f) + where + head (x:xs) = x + head [] = undefined + -- Andreas Abel, 2023-10-10, issue #32: + -- Redefine 'head' and 'tail' to avoid the x-partial warning of GHC 9.8. prop_tail f = not (LL.null f) ==> llcmp (LL.tail f) (tail (LL.toList f)) + where + tail (x:xs) = xs + tail [] = undefined prop_init f = not (LL.null f) ==> llcmp (LL.init f) (init (LL.toList f)) +prop_last f = not (LL.null f) ==> LL.last f == last (LL.toList f) prop_null f = LL.null f == null (LL.toList f) prop_length2 f = checkLengths f (LL.toList f) prop_length3 f1 f2 = llcmp (LL.append f1 f2) (LL.toList f1 ++ LL.toList f2) @@ -64,7 +80,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 @@ -85,16 +101,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_span f func = +prop_dropWhileEnd f func = llcmp (LL.dropWhileEnd func f) + (dropWhileEnd func (LL.toList f)) +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 = @@ -102,17 +120,22 @@ (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)) prop_isInfixOf f1 f2 = LL.isInfixOf f1 f2 == (isInfixOf (LL.toList f1) (LL.toList f2)) +prop_stripPrefix f1 f2 = (LL.toList <$> LL.stripPrefix f1 f2) == + (stripPrefix (LL.toList f1) (LL.toList f2)) +prop_stripPrefix2 f1 f2 = (LL.toList <$> LL.stripPrefix f1 (f1 <> f2)) == + (stripPrefix (LL.toList f1) (LL.toList $ f1 <> f2)) +prop_stripSuffix f1 f2 = LL.stripSuffix f1 (f2 <> f1) == Just f2 prop_elem f i = LL.elem i f == elem i (LL.toList f) 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) ==> @@ -135,7 +158,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 @@ -145,16 +168,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)) @@ -190,12 +213,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 @@ -203,7 +226,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) = @@ -221,7 +244,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] @@ -258,6 +281,7 @@ apf "splitAt" (t prop_splitAt), apf "takeWhile" (t prop_takeWhile), apf "dropWhile" (t prop_dropWhile), + apf "dropWhileEnd" (t prop_dropWhileEnd), apf "span" (t prop_span), apf "break" (t prop_break), apf "group" (t prop_group), @@ -266,6 +290,9 @@ apf "isPrefixOf" (t prop_isPrefixOf), apf "isSuffixOf" (t prop_isSuffixOf), apf "isInfixOf" (t prop_isInfixOf), + apf "stripPrefix" (t prop_stripPrefix), + apf "stripPrefix2" (t prop_stripPrefix2), + apf "stripSuffix" (t prop_stripSuffix), apf "elem" (t prop_elem), apf "notElem" (t prop_notElem), apf "find" (t prop_find), @@ -306,13 +333,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), @@ -324,14 +351,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) ] @@ -342,7 +369,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)