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: 4.2.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.md -Category: Generics -Cabal-Version: >= 1.8 +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,18 +23,42 @@ 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.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 @@ -44,34 +68,61 @@ Data.ListLike.DList Data.ListLike.FMList -- Other-Modules: Data.ConfigFile.Lexer - Build-Depends: base >= 4.6 && < 5 - ,containers >= 0.3 && < 0.6 - ,bytestring >= 0.9.1 && < 0.11 - ,array >= 0.3 && < 0.6 - ,text >= 0.11 && < 1.3 - ,vector >= 0.5 && < 0.12 - ,dlist >= 0.7 && < 0.9 - ,fmlist >= 0.8 && < 0.10 - + 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 - Hs-source-dirs: src testsrc + 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.2 && < 2 - ,QuickCheck >= 2.4 && < 3 - ,random >= 1 && < 2 - ,array - ,bytestring - ,containers - ,dlist - ,fmlist - ,text - ,vector + 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.md b/README.md --- a/README.md +++ b/README.md @@ -1,20 +1,13 @@ -[![Build Status](https://secure.travis-ci.org/JohnLato/listlike.png?branch=master)](http://travis-ci.org/JohnLato/listlike) +[![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 to allow -polymorphism over many common datatypes. - -Installation ------------- - -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: +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. -``` -$ runghc Setup.hs configure -$ runghc Setup.hs build -$ runghc Setup.hs install -``` +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 @@ -52,9 +52,11 @@ -- * Sublists -- ** Extracting sublists take, drop, splitAt, takeWhile, dropWhile, dropWhileEnd, span, break, - group, inits, tails, + group, inits, tails, -- ** Predicates isPrefixOf, isSuffixOf, isInfixOf, + -- ** Modify based on predicate + 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,20 +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, dropWhileEnd, 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, foldMap) +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.DList -import Data.ListLike.FMList +import Data.ListLike.Instances () +import Data.ListLike.DList () +import Data.ListLike.FMList () import Data.ListLike.String import Data.ListLike.Utils import Data.ListLike.IO @@ -159,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. -} @@ -222,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, dropWhileEnd, 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, foldMap) + +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,7 +227,7 @@ {- | 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 @@ -233,7 +250,7 @@ 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 @@ -268,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. -} @@ -277,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 @@ -298,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) @@ -313,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 @@ -323,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 @@ -340,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) [] @@ -396,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 @@ -460,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 @@ -470,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 @@ -500,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) @@ -511,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 @@ -543,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' @@ -556,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 @@ -566,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 @@ -592,6 +641,7 @@ isPrefixOf = L.isPrefixOf isSuffixOf = L.isSuffixOf isInfixOf = L.isInfixOf + stripPrefix = L.stripPrefix elem = L.elem notElem = L.notElem find = L.find @@ -601,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 @@ -626,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 --- a/src/Data/ListLike/DList.hs +++ b/src/Data/ListLike/DList.hs @@ -1,22 +1,29 @@ {-# 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 as P + +import qualified Prelude + import Data.ListLike.Base import Data.ListLike.FoldableLL -import Data.ListLike.IO import Data.ListLike.String -import Data.DList (DList(..)) +#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 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.List as List import qualified Data.String as S import Control.Category -import Data.Char (Char(..)) +import Data.Char (Char) + instance FoldableLL (DList a) a where foldl = F.foldl foldr = D.foldr @@ -32,16 +39,37 @@ 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 + --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 + -- 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 diff --git a/src/Data/ListLike/FMList.hs b/src/Data/ListLike/FMList.hs --- a/src/Data/ListLike/FMList.hs +++ b/src/Data/ListLike/FMList.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS -Wno-orphans #-} -- | 'Data.ListLike.ListLike' instances for 'Data.FMList.FMList' module Data.ListLike.FMList () where -import qualified Prelude as P +import Prelude hiding (cycle, map) import Data.ListLike.Base import Data.ListLike.FoldableLL -import Data.ListLike.IO +--import Data.ListLike.IO import Data.ListLike.String import Data.FMList (FMList(..)) import qualified Data.FMList as FM -import Data.Foldable (Foldable) +--import Data.Foldable (Foldable) import qualified Data.Foldable as F -import Data.Traversable (Traversable) -import qualified Data.Traversable as T +--import Data.Traversable (Traversable) +--import qualified Data.Traversable as T import Data.String (IsString) import qualified Data.String as S import Control.Monad.Zip (MonadZip) import qualified Control.Monad.Zip as Z -import Data.Function -import Data.Char (Char(..)) +--import Data.Function +import GHC.Exts (IsList(..)) instance FoldableLL (FMList a) a where foldl = F.foldl @@ -27,6 +28,11 @@ 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 @@ -37,8 +43,8 @@ tail = FM.tail last = FM.last init = FM.init - fromList = FM.fromList - toList = FM.toList + --fromList = FM.fromList + --toList = FM.toList null = FM.null genericLength = FM.genericLength length = FM.length @@ -58,7 +64,6 @@ fromString = FM.fromList instance StringLike (FMList Char) where - fromString = FM.fromList toString = FM.toList lines = map FM.fromList . S.lines . FM.toList words = map FM.fromList . S.words . FM.toList 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 + ) 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 ((><), (|>), (<|)) @@ -47,19 +51,26 @@ 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(..)) -------------------------------------------------- -- [] @@ -70,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 @@ -82,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 @@ -102,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 @@ -151,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 @@ -160,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 @@ -178,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 @@ -193,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 @@ -212,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 @@ -255,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_ @@ -271,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 @@ -293,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 @@ -308,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 @@ -325,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' @@ -333,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 @@ -366,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 @@ -399,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 @@ -409,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 @@ -422,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) @@ -432,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 @@ -479,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 @@ -506,7 +569,7 @@ reverse = S.reverse --intersperse = --concat = - --concatMap = + --concatMap = --rigidConcatMap = any = F.any all = F.all @@ -545,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 --- a/src/Data/ListLike/Text.hs +++ b/src/Data/ListLike/Text.hs @@ -1,9 +1,7 @@ -module Data.ListLike.Text ( - module Data.ListLike.Text.Text - ,module Data.ListLike.Text.TextLazy -) +module Data.ListLike.Text () where -import Data.ListLike.Text.Text -import Data.ListLike.Text.TextLazy +import Data.ListLike.Text.Builder () +import Data.ListLike.Text.Text () +import Data.ListLike.Text.TextLazy () diff --git a/src/Data/ListLike/Text/Builder.hs b/src/Data/ListLike/Text/Builder.hs 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 --- a/src/Data/ListLike/Text/Text.hs +++ b/src/Data/ListLike/Text/Text.hs @@ -1,14 +1,15 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} module Data.ListLike.Text.Text where import Prelude as P -import Control.Monad 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 @@ -59,14 +60,16 @@ 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 + --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) @@ -74,8 +77,8 @@ genericSplitAt i = T.splitAt (fromIntegral i) genericReplicate i = LL.replicate (fromIntegral i) - 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 instance ListLikeIO T.Text Char where hGetLine = TI.hGetLine @@ -95,8 +98,10 @@ instance StringLike T.Text where toString = T.unpack - fromString = T.pack 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 --- a/src/Data/ListLike/Text/TextLazy.hs +++ b/src/Data/ListLike/Text/TextLazy.hs @@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} module Data.ListLike.Text.TextLazy where import Prelude as P -import Control.Monad import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as TI import Data.Text.Encoding (decodeUtf8) @@ -58,13 +58,15 @@ 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 + --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) @@ -72,8 +74,8 @@ genericSplitAt i = T.splitAt (fromIntegral i) genericReplicate i = LL.replicate (fromIntegral i) - 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 instance ListLikeIO T.Text Char where hGetLine = TI.hGetLine @@ -93,8 +95,10 @@ instance StringLike T.Text where toString = T.unpack - fromString = T.pack 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,9 +26,10 @@ -} 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, @@ -39,7 +40,6 @@ 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 --- a/src/Data/ListLike/Vector.hs +++ b/src/Data/ListLike/Vector.hs @@ -2,14 +2,10 @@ -- The @Data.ListLike.Vector.Generic@ instances are not exported from this -- module in order to prevent collisions. -- -module Data.ListLike.Vector ( - module Data.ListLike.Vector.Storable - ,module Data.ListLike.Vector.Unboxed - ,module Data.ListLike.Vector.Vector -) +module Data.ListLike.Vector () where -import Data.ListLike.Vector.Storable -import Data.ListLike.Vector.Unboxed -import Data.ListLike.Vector.Vector +import Data.ListLike.Vector.Storable () +import Data.ListLike.Vector.Unboxed () +import Data.ListLike.Vector.Vector () diff --git a/src/Data/ListLike/Vector/Generic.hs b/src/Data/ListLike/Vector/Generic.hs --- a/src/Data/ListLike/Vector/Generic.hs +++ b/src/Data/ListLike/Vector/Generic.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE MultiParamTypeClasses - ,FlexibleContexts - ,FlexibleInstances - ,OverlappingInstances - ,UndecidableInstances #-} +{-# 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. @@ -12,16 +16,15 @@ where import Prelude as P -import Control.Monad 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.Monoid +import Data.String (IsString) +import GHC.Exts (IsList(..)) -instance V.Vector v a => FoldableLL (v a) a where +instance {-# OVERLAPPABLE #-} V.Vector v a => FoldableLL (v a) a where foldl = V.foldl foldl' = V.foldl' foldl1 = V.foldl1 @@ -29,7 +32,14 @@ foldr' = V.foldr' foldr1 = V.foldr1 -instance (Monoid (v a), Eq (v a), V.Vector v a) => ListLike (v a) a where +#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 @@ -68,33 +78,37 @@ filter = V.filter index = (!) findIndex = V.findIndex - toList = V.toList - fromList = V.fromList - fromListLike = fromList . toList - --groupBy f = + --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 = + --genericSplitAt i = genericReplicate i = V.replicate (fromIntegral i) - 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 +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 - fromString = V.fromList --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 = diff --git a/src/Data/ListLike/Vector/Storable.hs b/src/Data/ListLike/Vector/Storable.hs --- a/src/Data/ListLike/Vector/Storable.hs +++ b/src/Data/ListLike/Vector/Storable.hs @@ -1,19 +1,20 @@ {-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} module Data.ListLike.Vector.Storable () where import Prelude as P -import Control.Monad 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 Data.Monoid import Foreign.Storable (Storable) @@ -64,33 +65,37 @@ filter = V.filter index = (!) findIndex = V.findIndex - toList = V.toList - fromList = V.fromList - fromListLike = fromList . toList - --groupBy f = + --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 = + --genericSplitAt i = genericReplicate i = V.replicate (fromIntegral i) - 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 +instance IsString (V.Vector Char) where + fromString = fromList + instance StringLike (V.Vector Char) where toString = toList - fromString = fromList --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 = @@ -99,4 +104,3 @@ 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 --- a/src/Data/ListLike/Vector/Unboxed.hs +++ b/src/Data/ListLike/Vector/Unboxed.hs @@ -1,19 +1,19 @@ {-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} module Data.ListLike.Vector.Unboxed () where import Prelude as P -import Control.Monad 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.Monoid +import Data.String (IsString) instance Unbox a => FoldableLL (V.Vector a) a where @@ -63,33 +63,37 @@ filter = V.filter index = (!) findIndex = V.findIndex - toList = V.toList - fromList = V.fromList - fromListLike = fromList . toList - --groupBy f = + --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 = + --genericSplitAt i = genericReplicate i = V.replicate (fromIntegral i) - 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 +instance IsString (V.Vector Char) where + fromString = fromList + instance StringLike (V.Vector Char) where toString = toList - fromString = fromList --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 = @@ -98,4 +102,3 @@ 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 --- a/src/Data/ListLike/Vector/Vector.hs +++ b/src/Data/ListLike/Vector/Vector.hs @@ -1,19 +1,19 @@ {-# LANGUAGE MultiParamTypeClasses + ,TypeFamilies ,FlexibleInstances #-} +{-# OPTIONS -Wno-orphans #-} module Data.ListLike.Vector.Vector () where import Prelude as P -import Control.Monad import qualified Data.Vector as V import Data.Vector ((!)) import Data.ListLike.Base import Data.ListLike.FoldableLL import Data.ListLike.String - -import Data.Monoid +import Data.String (IsString) instance FoldableLL (V.Vector a) a where foldl = V.foldl @@ -62,33 +62,37 @@ filter = V.filter index = (!) findIndex = V.findIndex - toList = V.toList - fromList = V.fromList - fromListLike = fromList . toList - --groupBy f = + --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 = + --genericSplitAt i = genericReplicate i = V.replicate (fromIntegral i) - 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 +instance IsString (V.Vector Char) where + fromString = fromList + instance StringLike (V.Vector Char) where toString = toList - fromString = fromList --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 = diff --git a/testsrc/TestInfrastructure.hs b/testsrc/TestInfrastructure.hs --- a/testsrc/TestInfrastructure.hs +++ b/testsrc/TestInfrastructure.hs @@ -6,7 +6,9 @@ ,FunctionalDependencies ,FlexibleInstances ,UndecidableInstances + ,TypeFamilies ,FlexibleContexts #-} +{-# OPTIONS -Wno-orphans #-} {- Copyright (C) 2007 John Goerzen @@ -25,24 +27,30 @@ 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.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.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 +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) @@ -74,34 +82,34 @@ instance (CoArbitrary i) => CoArbitrary (FM.FMList i) where coarbitrary l = coarbitrary (LL.toList l) -instance (Arbitrary i) => Arbitrary (S.Seq i) where +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 i) => CoArbitrary (S.Seq i) where +instance CoArbitrary (BSL.ByteString) where coarbitrary l = coarbitrary (LL.toList l) -instance Arbitrary (BSL.ByteString) where +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 (BSL.ByteString) where +instance CoArbitrary (BS.ByteString) where coarbitrary l = coarbitrary (LL.toList l) -instance Arbitrary (BS.ByteString) where +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 (BS.ByteString) where +instance CoArbitrary Chars.Chars where coarbitrary l = coarbitrary (LL.toList l) instance Arbitrary i => Arbitrary (A.Array Int i) where @@ -134,6 +142,36 @@ 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 = @@ -183,6 +221,8 @@ 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 @@ -191,6 +231,12 @@ 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 @@ -212,38 +258,50 @@ 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 (MyList x) (MyList y) = MyList (x ++ y) + 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] - head (MyList x) = head x - tail (MyList x) = MyList (tail 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 - fromString x = MyList x -mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheck test) +mkTest :: Testable prop => String -> prop -> HU.Test +mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheckResult test >>= HU.assertBool msg . isSuccess) -- Modified from HUnit runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st) -runVerbTestText (HU.PutText put us) t = do - (counts, us') <- HU.performTest reportStart reportError reportFailure us t +runVerbTestText (HU.PutText put us) test = do + (counts, us') <- HU.performTest reportStart reportError reportFailure us test us'' <- put (HU.showCounts counts) True us' return (counts, us'') where - reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss)) - put (HU.showCounts (HU.counts ss)) False us + reportStart ss us' = do + hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss)) + put (HU.showCounts (HU.counts ss)) False us' reportError = reportProblem "Error:" "Error in: " reportFailure = reportProblem "Failure:" "Failure in: " -#if MIN_VERSION_HUnit(1,3,0) - reportProblem p0 p1 _mloc msg ss us = put line True us -#else - reportProblem p0 p1 msg ss us = put line True us -#endif + 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) @@ -260,8 +318,7 @@ forall t. Testable t => LLWrap (f' -> t) w :: TestLL f i => String -> LLTest f i -> HU.Test -w msg f = case f of - LLTest theTest -> mkTest msg theTest +w msg (LLTest theTest) = mkTest msg theTest ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test ws = w @@ -280,12 +337,12 @@ 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) + 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 :: 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), @@ -294,6 +351,7 @@ 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), @@ -309,22 +367,29 @@ 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.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 :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test aps msg x = HU.TestLabel msg $ HU.TestList $ [w "String" (x::LLTest String Char), w "MyList Char" (x::LLTest (MyList Char) Char), w "Sequence Char" (x::LLTest (S.Seq Char) Char), w "DList Char" (x::LLTest (DL.DList Char) Char), -- w "FMList Char" (x::LLTest (FM.FMList Char) Char), - w "ByteString" (x::LLTest BS.ByteString Word8), - w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8), + -- w "ByteString" (x::LLTest BS.ByteString Word8), + -- w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8), + w "Chars" (x::LLTest Chars.Chars Char), w "Array Int Char" (x::LLTest (A.Array Int Char) Char), w "Text" (x::LLTest T.Text Char), 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,18 +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_dropWhileEnd f func = llcmp (LL.dropWhileEnd func f) (dropWhileEnd func (LL.toList f)) -prop_span f func = +prop_span f func = llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.span func $ f] [span func (LL.toList f)] -prop_break f func = +prop_break f func = llcmp [(\(x, y) -> (LL.toList x, LL.toList y)) . LL.break func $ f] [break func (LL.toList f)] prop_group f = @@ -104,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) ==> @@ -137,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 @@ -147,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)) @@ -192,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 @@ -205,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) = @@ -223,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] @@ -269,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), @@ -309,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), @@ -327,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) ] @@ -345,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)