diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,139 @@ +# ChangeLog for mono-traversable + +## 1.0.21.0 + +* Support for vector 0.13.2.0, adding instances for [`Data.Vector.Strict`](https://hackage.haskell.org/package/vector-0.13.2.0/docs/Data-Vector-Strict.html) data structure. + [#244](https://github.com/snoyberg/mono-traversable/issues/244) + +## 1.0.20.0 + +* Added instances for [`Reverse`](https://hackage.haskell.org/package/transformers-0.6.1.1/docs/Data-Functor-Reverse.html#t:Reverse) data structure. + +## 1.0.19.1 + +* Removed 'highly experimental' warning haddock comment from Data.Containers. + +## 1.0.19.0 + +* Added `filterWithKey` to `IsMap`. + [#232](https://github.com/snoyberg/mono-traversable/pull/232) + +## 1.0.18.0 + +* Added MonoPointed instance for text Builder + [#225](https://github.com/snoyberg/mono-traversable/pull/225) + +## 1.0.17.0 + +* Added `inits`, `tails`, `initTails` to class `IsSequence` with tests and benchmarks for `initTails`. +* Improved ghc benchmark flags. +* Removed extraneous constraint `IsSequence` from `initMay`. + +## 1.0.16.0 + +* Added MonoPointed instance for bytestring Builder + [#219](https://github.com/snoyberg/mono-traversable/pull/219#pullrequestreview-1879553961) + +## 1.0.15.3 + +* Compile with GHC 9.2 (`Option` removed from `base-4.16`) + [#199](https://github.com/snoyberg/mono-traversable/issues/199) + +## 1.0.15.2 + +* Support transformers 0.6.0.0 [#196](https://github.com/snoyberg/mono-traversable/issues/196) +* Compile with GHC 9 [#193](https://github.com/snoyberg/mono-traversable/pull/193) + +## 1.0.15.1 + +* Remove whitespace after `@` in as-patterns for GHC HEAD [#186](https://github.com/snoyberg/mono-traversable/pull/186) + +## 1.0.15.0 + +* Added `toNonEmpty` to `Data.NonNull` + [#185](https://github.com/snoyberg/mono-traversable/pull/185) + +## 1.0.14.0 +* Added `WrappedMono` to `Data.MonoTraversable` + [#182](https://github.com/snoyberg/mono-traversable/pull/182) + +## 1.0.13.0 +* Added `WrappedPoly` to `Data.MonoTraversable` + [#180](https://github.com/snoyberg/mono-traversable/pull/180) + +## 1.0.12.0 +* Added `filterSet` to `Data.Containers` +* Use container specific implementations for `filterSet` and `filterMap` + [#178](https://github.com/snoyberg/mono-traversable/pull/178) + +## 1.0.11.0 + +* Adding monomorphic instances for GHC.Generics and Data.Proxy types + [#175](https://github.com/snoyberg/mono-traversable/issues/175) + +## 1.0.10.0 + +* Make index work on negative indices + [#172](https://github.com/snoyberg/mono-traversable/issues/172) + [#114](https://github.com/snoyberg/mono-traversable/issues/114) + +## 1.0.9.0 + +* Added `filterMap` to `Data.Containers` + [#167](https://github.com/snoyberg/mono-traversable/pull/167) + +## 1.0.8.1 + +* Compat with gauge 0.1 and 0.2 + +## 1.0.8.0 + +* Switch to gauge +* Relax constraint on `singleton` to `MonoPointed` + [#156](https://github.com/snoyberg/mono-traversable/issues/156) + +## 1.0.7.0 + +* Add `dropPrefix` and `dropSuffix` to `Data.Sequences` [#139](https://github.com/snoyberg/mono-traversable/issues/139) +* Change `sort` implementation [#153](https://github.com/snoyberg/mono-traversable/issues/153) + +## 1.0.6.0 + +* Add `mapNonNull` function to `Data.NonNull` [#150](https://github.com/snoyberg/mono-traversable/issues/150) + +## 1.0.5.0 + +* Move `oelem` and `onotElem` into the `MonoFoldable` class [#133](https://github.com/snoyberg/mono-traversable/issues/133) + * Change `instance MonoFoldable (Set e)` to `instance Ord e => MonoFoldable (Set e)` + +## 1.0.4.0 + +* Add `dropEnd` function to the `IsSequence` class, and a specialized implementation for `Text` + +## 1.0.3.0 + +* Add `ensurePrefix` and `ensureSuffix` functions [#141](https://github.com/snoyberg/mono-traversable/pull/141) + +## 1.0.2.1 + +* Fix test suite for foldl 1.3 + +## 1.0.2 + +* `IsSequence` class: add `lengthIndex` [#127](https://github.com/snoyberg/mono-traversable/pull/127) + +## 1.0.1.3 + +* Make 'olength' for Set and Map O(1) [#125](https://github.com/snoyberg/mono-traversable/pull/125) + +## 1.0.1.2 + +* Support for GHC 8.2 + +## 1.0.1.1 + +* Fix typo in rewrite rule + ## 1.0.1 * Add `replaceElem` and `replaceSeq` [#107](https://github.com/snoyberg/mono-traversable/pull/107) @@ -71,7 +207,7 @@ `EqSequence` now inherits from `MonoFoldableEq`. For most users that do not define instances this should not be a breaking change. -However, any instance of `EqSequence` now needs to definie `MonoFoldableEq`. +However, any instance of `EqSequence` now needs to define `MonoFoldableEq`. ## 0.7.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ In addition to this package, the [mono-traversable-instances](https://www.stackage.org/package/mono-traversable-instances) -pacakge provides a number of orphan instances. +package provides a number of orphan instances. Using Typeclasses @@ -155,7 +155,7 @@ * IsMap: unifies operations across different `Map`s * MonoZip: zip operations on MonoFunctors. -Note that because `Set` and `Map` are not a Functor (and therefore not MonoFoldable), one must use `mapFromList`, `mapToList`, `setFromList`, and `setToList`. +Note that because `Set` is not a Functor (and therefore neither a MonoFunctor nor MonoTraversable), one must use `setFromList` and `setToList` to `omap` or `otraverse` over the elements of a `Set`. ### Sequences diff --git a/bench/InitTails.hs b/bench/InitTails.hs new file mode 100644 --- /dev/null +++ b/bench/InitTails.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +module InitTails (initTailsBenchmarks) where + +#if MIN_VERSION_gauge(0,2,0) +import Gauge +#else +import Gauge.Main +#endif + +import Data.Sequences as Ss +import Data.MonoTraversable +import Type.Reflection (Typeable, typeRep) +import Control.DeepSeq +import Data.Foldable (foldl') +import Data.Functor ((<&>)) + +import Data.ByteString (StrictByteString) +import Data.ByteString.Lazy (LazyByteString) +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL +import Data.Sequence (Seq) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS + +initTailsBenchmarks :: Benchmark +initTailsBenchmarks = bgroup "InitTails" + [ bmg @[Char] + , bmg @StrictByteString + , bmg @LazyByteString + , bmg @TS.Text + , bmg @TL.Text + , bmg @(Seq Char) + , bmg @(V.Vector Char) + , bmg @(VU.Vector Char) + , bmg @(VS.Vector Char) + ] + +bmg :: forall seq. + ( TestLabel seq + , NFData seq + , IsSequence seq + , Num (Index seq) + , Enum (Element seq) + ) => Benchmark +bmg = bgroup (testLabel @seq) $ bm <$> labelledLengths + where + bm :: (String,[Int]) -> Benchmark + bm (label,lengths) = bgroup label $ + [ ("weak", weakConsume) + , ("deep", deepConsume) + ] <&> \(wdLabel,consume) -> bench wdLabel + $ nf (map $ consume . initTails @seq) + $ (`Ss.replicate` (toEnum 65)) . fromIntegral <$> lengths + labelledLengths = + [ ("tiny", [0,1,2,5,10]) + , ("small", [100,150,200,300]) + , ("medium", [1000,1500,2000,2500]) + , ("large", [10000,20000,50000]) + ] + +class Typeable a => TestLabel a where + testLabel :: String + testLabel = show $ typeRep @a +instance TestLabel [Char] +instance TestLabel StrictByteString where testLabel = "StrictByteString" +instance TestLabel LazyByteString where testLabel = "LazyByteString" +instance TestLabel TS.Text where testLabel = "StrictText" +instance TestLabel TL.Text where testLabel = "LazyText" +instance TestLabel (Seq Char) where testLabel = "Seq" +instance TestLabel (V.Vector Char) where testLabel = "Vector" +instance TestLabel (VU.Vector Char) where testLabel = "UnboxedVector" +instance TestLabel (VS.Vector Char) where testLabel = "StorableVector" + + +-- *Consume used to keep memory usage lower +deepConsume :: NFData seq => [(seq,seq)] -> () +deepConsume = foldl' (\() (is,ts) -> deepseq is $ deepseq ts ()) () + +weakConsume :: [(seq,seq)] -> () +weakConsume = foldl' (\() (_,_) -> ()) () + diff --git a/bench/Sorting.hs b/bench/Sorting.hs new file mode 100644 --- /dev/null +++ b/bench/Sorting.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +module Sorting (sortingBenchmarks) where + +#if MIN_VERSION_gauge(0,2,0) +import Gauge +#else +import Gauge.Main +#endif + +import Data.Sequences +import Data.MonoTraversable +import qualified Data.List +import qualified System.Random.MWC as MWC +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import System.IO.Unsafe (unsafePerformIO) + +sortingBenchmarks :: Benchmark +sortingBenchmarks + = bgroup "Sorting" + $ unsafePerformIO + $ mapM mkGroup [10, 100, 1000, 10000] + +asVector :: V.Vector a -> V.Vector a +asVector = id + +asUVector :: U.Vector a -> U.Vector a +asUVector = id + +mkGroup :: Int -> IO Benchmark +mkGroup size = do + gen <- MWC.create + inputV <- MWC.uniformVector gen size + let inputL = otoList (inputV :: V.Vector Int) + inputVU = fromList inputL :: U.Vector Int + return $ bgroup (show size) + [ bench "Data.List.sort" $ nf Data.List.sort inputL + , bench "list sort" $ nf sort inputL + , bench "list sort, via vector" $ nf (otoList . sort . asVector . fromList) inputL + , bench "list sort, via uvector" $ nf (otoList . sort . asUVector . fromList) inputL + , bench "vector sort" $ nf sort inputV + , bench "uvector sort" $ nf sort inputVU + ] diff --git a/bench/main.hs b/bench/main.hs new file mode 100644 --- /dev/null +++ b/bench/main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_gauge(0,2,0) +import Gauge +#else +import Gauge.Main +#endif + +import Sorting (sortingBenchmarks) +import InitTails (initTailsBenchmarks) + + +main :: IO () +main = defaultMain + [ sortingBenchmarks + , initTailsBenchmarks + ] diff --git a/bench/sorting.hs b/bench/sorting.hs deleted file mode 100644 --- a/bench/sorting.hs +++ /dev/null @@ -1,32 +0,0 @@ -import Criterion.Main -import Data.Sequences -import Data.MonoTraversable -import qualified Data.List -import qualified System.Random.MWC as MWC -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U - -asVector :: V.Vector a -> V.Vector a -asVector = id - -asUVector :: U.Vector a -> U.Vector a -asUVector = id - -main :: IO () -main = do - mapM mkGroup [10, 100, 1000, 10000] >>= defaultMain - -mkGroup :: Int -> IO Benchmark -mkGroup size = do - gen <- MWC.create - inputV <- MWC.uniformVector gen size - let inputL = otoList (inputV :: V.Vector Int) - inputVU = fromList inputL :: U.Vector Int - return $ bgroup (show size) - [ bench "Data.List.sort" $ nf Data.List.sort inputL - , bench "list sort" $ nf sort inputL - , bench "list sort, via vector" $ nf (otoList . sort . asVector . fromList) inputL - , bench "list sort, via uvector" $ nf (otoList . sort . asUVector . fromList) inputL - , bench "vector sort" $ nf sort inputV - , bench "uvector sort" $ nf sort inputVU - ] diff --git a/mono-traversable.cabal b/mono-traversable.cabal --- a/mono-traversable.cabal +++ b/mono-traversable.cabal @@ -1,75 +1,99 @@ -name: mono-traversable -version: 1.0.1 -synopsis: Type classes for mapping, folding, and traversing monomorphic containers -description: Monomorphic variants of the Functor, Foldable, and Traversable typeclasses. If you understand Haskell's basic typeclasses, you understand mono-traversable. In addition to what you are used to, it adds on an IsSequence typeclass and has code for marking data structures as non-empty. -homepage: https://github.com/snoyberg/mono-traversable -license: MIT -license-file: LICENSE -author: Michael Snoyman, John Wiegley, Greg Weber -maintainer: michael@snoyman.com -category: Data -build-type: Simple -extra-source-files: README.md - ChangeLog.md -cabal-version: >=1.10 +cabal-version: 1.12 -library - ghc-options: -Wall - exposed-modules: Data.MonoTraversable - Data.MonoTraversable.Unprefixed - Data.Containers - Data.Sequences - Data.NonNull - build-depends: base >= 4.5 && < 5 - , containers >= 0.4 - , unordered-containers >=0.2 - , hashable - , bytestring >= 0.9 - , text >=0.11 - , transformers >=0.3 - , vector >=0.10 - , vector-algorithms >= 0.6 - , split >= 0.2 +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack - if impl(ghc < 8.0) - build-depends: semigroups >= 0.10 +name: mono-traversable +version: 1.0.21.0 +synopsis: Type classes for mapping, folding, and traversing monomorphic containers +description: Please see the README at +category: Data +homepage: https://github.com/snoyberg/mono-traversable#readme +bug-reports: https://github.com/snoyberg/mono-traversable/issues +author: Michael Snoyman, John Wiegley, Greg Weber +maintainer: michael@snoyman.com +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md - hs-source-dirs: src - default-language: Haskell2010 +source-repository head + type: git + location: https://github.com/snoyberg/mono-traversable -test-suite test - main-is: main.hs - type: exitcode-stdio-1.0 - hs-source-dirs: test - other-modules: Spec - default-language: Haskell2010 - ghc-options: -O0 - build-depends: base - , mono-traversable - , bytestring - , text - , hspec - , HUnit - , transformers - , vector - , QuickCheck - , semigroups - , containers - , unordered-containers - , foldl +library + exposed-modules: + Data.Containers + Data.MonoTraversable + Data.MonoTraversable.Unprefixed + Data.NonNull + Data.Sequences + other-modules: + Paths_mono_traversable + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.13 && <5 + , bytestring >=0.9 + , containers >=0.5.8 + , hashable + , split >=0.2 + , text >=0.11 + , transformers >=0.3 + , unordered-containers >=0.2 + , vector >=0.10 + , vector-algorithms >=0.6 + default-language: Haskell2010 -benchmark sorting - type: exitcode-stdio-1.0 - hs-source-dirs: bench - build-depends: base - , criterion - , mono-traversable - , vector - , mwc-random - main-is: sorting.hs - ghc-options: -Wall -O2 - default-language: Haskell2010 +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_mono_traversable + hs-source-dirs: + test + ghc-options: -O0 + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + HUnit + , QuickCheck + , base + , bytestring + , containers + , foldl + , hspec + , mono-traversable + , text + , transformers + , unordered-containers + , vector + default-language: Haskell2010 -source-repository head - type: git - location: git://github.com/snoyberg/mono-traversable.git +benchmark all + type: exitcode-stdio-1.0 + main-is: main.hs + other-modules: + InitTails + Sorting + Paths_mono_traversable + hs-source-dirs: + bench + ghc-options: -Wall -O2 -with-rtsopts=-A32m + build-depends: + base + , bytestring + , containers + , deepseq + , gauge + , mono-traversable + , mwc-random + , text + , vector + default-language: Haskell2010 + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 diff --git a/src/Data/Containers.hs b/src/Data/Containers.hs --- a/src/Data/Containers.hs +++ b/src/Data/Containers.hs @@ -4,24 +4,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} --- | Warning: This module should be considered highly experimental. +{-# LANGUAGE TypeOperators #-} module Data.Containers where import Prelude hiding (lookup) import Data.Maybe (fromMaybe) -#if MIN_VERSION_containers(0, 5, 0) import qualified Data.Map.Strict as Map import qualified Data.IntMap.Strict as IntMap -#else -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -#endif import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) import qualified Data.Set as Set import qualified Data.HashSet as HashSet import Data.Monoid (Monoid (..)) -import Data.Semigroup (Semigroup) import Data.MonoTraversable (MonoFunctor(..), MonoFoldable, MonoTraversable, Element, GrowingAppend, ofoldl', otoList) import Data.Function (on) import qualified Data.List as List @@ -67,9 +61,7 @@ -- | Get a list of all of the keys in the container. keys :: set -> [ContainerKey set] -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.Map.Strict". -#endif instance Ord k => SetContainer (Map.Map k v) where type ContainerKey (Map.Map k v) = k member = Map.member @@ -87,9 +79,7 @@ keys = Map.keys {-# INLINE keys #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.HashMap.Strict". -#endif instance (Eq key, Hashable key) => SetContainer (HashMap.HashMap key value) where type ContainerKey (HashMap.HashMap key value) = key member = HashMap.member @@ -107,9 +97,7 @@ keys = HashMap.keys {-# INLINE keys #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.IntMap.Strict". -#endif instance SetContainer (IntMap.IntMap value) where type ContainerKey (IntMap.IntMap value) = Int member = IntMap.member @@ -213,9 +201,7 @@ intersectionWithMap :: (value1 -> value2 -> value3) -> map value1 -> map value2 -> map value3 -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.Map.Strict". -#endif instance Ord key => PolyMap (Map.Map key) where differenceMap = Map.difference {-# INLINE differenceMap #-} @@ -225,9 +211,7 @@ intersectionWithMap = Map.intersectionWith {-# INLINE intersectionWithMap #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.HashMap.Strict". -#endif instance (Eq key, Hashable key) => PolyMap (HashMap.HashMap key) where differenceMap = HashMap.difference {-# INLINE differenceMap #-} @@ -237,9 +221,7 @@ intersectionWithMap = HashMap.intersectionWith {-# INLINE intersectionWithMap #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.IntMap.Strict". -#endif instance PolyMap IntMap.IntMap where differenceMap = IntMap.difference {-# INLINE differenceMap #-} @@ -562,9 +544,20 @@ where go (k, v) = [(f k, v)] -#if MIN_VERSION_containers(0, 5, 0) + -- | Filter values in a map. + -- + -- @since 1.0.9.0 + filterMap :: (MapValue map -> Bool) -> map -> map + filterMap = filterWithKey . const + + -- | Equivalent to 'filterMap', but the function accepts the key, + -- as well as the value. + -- + -- @since 1.0.19.0 + filterWithKey :: (ContainerKey map -> MapValue map -> Bool) -> map -> map + filterWithKey p = mapFromList . filter (uncurry p) . mapToList + -- | This instance uses the functions from "Data.Map.Strict". -#endif instance Ord key => IsMap (Map.Map key value) where type MapValue (Map.Map key value) = value lookup = Map.lookup @@ -610,10 +603,12 @@ {-# INLINE mapWithKey #-} omapKeysWith = Map.mapKeysWith {-# INLINE omapKeysWith #-} + filterMap = Map.filter + {-# INLINE filterMap #-} + filterWithKey = Map.filterWithKey + {-# INLINE filterWithKey #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.HashMap.Strict". -#endif instance (Eq key, Hashable key) => IsMap (HashMap.HashMap key value) where type MapValue (HashMap.HashMap key value) = value lookup = HashMap.lookup @@ -647,10 +642,12 @@ --unionsWith = HashMap.unionsWith --mapWithKey = HashMap.mapWithKey --mapKeysWith = HashMap.mapKeysWith + filterMap = HashMap.filter + {-# INLINE filterMap #-} + filterWithKey = HashMap.filterWithKey + {-# INLINE filterWithKey #-} -#if MIN_VERSION_containers(0, 5, 0) -- | This instance uses the functions from "Data.IntMap.Strict". -#endif instance IsMap (IntMap.IntMap value) where type MapValue (IntMap.IntMap value) = value lookup = IntMap.lookup @@ -693,10 +690,12 @@ {-# INLINE unionsWith #-} mapWithKey = IntMap.mapWithKey {-# INLINE mapWithKey #-} -#if MIN_VERSION_containers(0, 5, 0) omapKeysWith = IntMap.mapKeysWith {-# INLINE omapKeysWith #-} -#endif + filterMap = IntMap.filter + {-# INLINE filterMap #-} + filterWithKey = IntMap.filterWithKey + {-# INLINE filterWithKey #-} instance Eq key => IsMap [(key, value)] where type MapValue [(key, value)] = value @@ -730,6 +729,12 @@ -- | Convert a set to a list. setToList :: set -> [Element set] + -- | Filter values in a set. + -- + -- @since 1.0.12.0 + filterSet :: (Element set -> Bool) -> set -> set + filterSet p = setFromList . filter p . setToList + instance Ord element => IsSet (Set.Set element) where insertSet = Set.insert {-# INLINE insertSet #-} @@ -741,6 +746,8 @@ {-# INLINE setFromList #-} setToList = Set.toList {-# INLINE setToList #-} + filterSet = Set.filter + {-# INLINE filterSet #-} instance (Eq element, Hashable element) => IsSet (HashSet.HashSet element) where insertSet = HashSet.insert @@ -753,6 +760,8 @@ {-# INLINE setFromList #-} setToList = HashSet.toList {-# INLINE setToList #-} + filterSet = HashSet.filter + {-# INLINE filterSet #-} instance IsSet IntSet.IntSet where insertSet = IntSet.insert @@ -765,6 +774,8 @@ {-# INLINE setFromList #-} setToList = IntSet.toList {-# INLINE setToList #-} + filterSet = IntSet.filter + {-# INLINE filterSet #-} -- | Zip operations on 'MonoFunctor's. diff --git a/src/Data/MonoTraversable.hs b/src/Data/MonoTraversable.hs --- a/src/Data/MonoTraversable.hs +++ b/src/Data/MonoTraversable.hs @@ -1,10 +1,14 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Type classes mirroring standard typeclasses, but working with monomorphic containers. -- -- The motivation is that some commonly used data types (i.e., 'ByteString' and @@ -26,23 +30,23 @@ import Control.Applicative import Control.Category -#if MIN_VERSION_base(4,8,0) import Control.Monad (Monad (..)) -#else -import Control.Monad (Monad (..), liftM) -#endif import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Builder as B import qualified Data.Foldable as F import Data.Functor import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid (..), Any (..), All (..)) +import Data.Monoid (Dual(..), Monoid (..), Any (..), All (..)) +import Data.Proxy import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB import Data.Traversable import Data.Word (Word8) import Data.Int (Int, Int64) import GHC.Exts (build) +import GHC.Generics ((:.:), (:*:), (:+:)(..), K1(..), M1(..), Par1(..), Rec1(..), U1(..), V1) import Prelude (Bool (..), const, Char, flip, IO, Maybe (..), Either (..), (+), Integral, Ordering (..), compare, fromIntegral, Num, (>=), (==), seq, otherwise, Eq, Ord, (-), (*)) @@ -52,6 +56,7 @@ import Foreign.Ptr (plusPtr) import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Storable (peek) +import Control.Applicative.Backwards (Backwards (..)) import Control.Arrow (Arrow) import Data.Tree (Tree (..)) import Data.Sequence (Seq, ViewL (..), ViewR (..)) @@ -61,11 +66,15 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) import Data.Functor.Identity (Identity) +import Data.Functor.Reverse (Reverse (..)) import Data.Map (Map) +import qualified Data.Map.Strict as Map import Data.HashMap.Strict (HashMap) import Data.Vector (Vector) import Control.Monad.Trans.Maybe (MaybeT (..)) +#if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.List (ListT) +#endif import Control.Monad.Trans.Writer (WriterT) import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) import Control.Monad.Trans.State (StateT(..)) @@ -84,8 +93,20 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Storable as VS +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VSC +#else +{-# DependencyDeprecation "Support for vector < 0.13.2 will be removed when GHC 9.12 reaches Stackage nightly. Please upgrade to vector >= 0.13.2." #-} +#endif import qualified Data.IntSet as IntSet -import Data.Semigroup (Semigroup, Option (..), Arg) +import Data.Semigroup + ( Semigroup +-- Option has been removed in base-4.16 (GHC 9.2) +#if !MIN_VERSION_base(4,16,0) + , Option (..) +#endif + , Arg + ) import qualified Data.ByteString.Unsafe as SU import Control.Monad.Trans.Identity (IdentityT) @@ -94,8 +115,12 @@ type family Element mono type instance Element S.ByteString = Word8 type instance Element L.ByteString = Word8 +-- | @since 1.0.16.0 +type instance Element B.Builder = Word8 type instance Element T.Text = Char type instance Element TL.Text = Char +-- | @since 1.0.18.0 +type instance Element TB.Builder = Char type instance Element [a] = a type instance Element (IO a) = a type instance Element (ZipList a) = a @@ -106,7 +131,9 @@ type instance Element (ViewR a) = a type instance Element (IntMap a) = a type instance Element IntSet = Int +#if !MIN_VERSION_base(4,16,0) type instance Element (Option a) = a +#endif type instance Element (NonEmpty a) = a type instance Element (Identity a) = a type instance Element (r -> a) = a @@ -121,7 +148,9 @@ type instance Element (Vector a) = a type instance Element (WrappedArrow a b c) = c type instance Element (MaybeT m a) = a +#if !MIN_VERSION_transformers(0,6,0) type instance Element (ListT m a) = a +#endif type instance Element (IdentityT m a) = a type instance Element (WriterT w m a) = a type instance Element (Strict.WriterT w m a) = a @@ -135,13 +164,29 @@ type instance Element (Product f g a) = a type instance Element (U.Vector a) = a type instance Element (VS.Vector a) = a +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +type instance Element (VSC.Vector a) = a +#endif type instance Element (Arg a b) = b +type instance Element ((f :.: g) a) = a +type instance Element ((f :*: g) a) = a +type instance Element ((f :+: g) a) = a +type instance Element (K1 i c a) = a +type instance Element (M1 i c f a) = a +type instance Element (Rec1 f a) = a +type instance Element (Par1 a) = a +type instance Element (U1 a) = a +type instance Element (V1 a) = a +type instance Element (Proxy a) = a +type instance Element (Reverse f a) = Element (f a) -- | Monomorphic containers that can be mapped over. class MonoFunctor mono where -- | Map over a monomorphic container omap :: (Element mono -> Element mono) -> mono -> mono - default omap :: (Functor f, Element (f a) ~ a, f a ~ mono) => (a -> a) -> f a -> f a + default omap :: (Functor f, Element (f a) ~ a, f a ~ mono) + => (Element mono -> Element mono) -> mono -> mono omap = fmap {-# INLINE omap #-} @@ -166,7 +211,9 @@ instance MonoFunctor (ViewL a) instance MonoFunctor (ViewR a) instance MonoFunctor (IntMap a) +#if !MIN_VERSION_base(4,16,0) instance MonoFunctor (Option a) +#endif instance MonoFunctor (NonEmpty a) instance MonoFunctor (Identity a) instance MonoFunctor (r -> a) @@ -180,7 +227,9 @@ instance MonoFunctor (Arg a b) instance Arrow a => MonoFunctor (WrappedArrow a b c) instance Functor m => MonoFunctor (MaybeT m a) +#if !MIN_VERSION_transformers(0,6,0) instance Functor m => MonoFunctor (ListT m a) +#endif instance Functor m => MonoFunctor (IdentityT m a) instance Functor m => MonoFunctor (WriterT w m a) instance Functor m => MonoFunctor (Strict.WriterT w m a) @@ -192,12 +241,39 @@ instance Functor m => MonoFunctor (ContT r m a) instance (Functor f, Functor g) => MonoFunctor (Compose f g a) instance (Functor f, Functor g) => MonoFunctor (Product f g a) +-- | @since 1.0.11.0 +instance (Functor f, Functor g) => MonoFunctor ((f :.: g) a) +-- | @since 1.0.11.0 +instance (Functor f, Functor g) => MonoFunctor ((f :*: g) a) +-- | @since 1.0.11.0 +instance (Functor f, Functor g) => MonoFunctor ((f :+: g) a) +-- | @since 1.0.11.0 +instance MonoFunctor (K1 i c a) +-- | @since 1.0.11.0 +instance Functor f => MonoFunctor (M1 i c f a) +-- | @since 1.0.11.0 +instance Functor f => MonoFunctor (Rec1 f a) +-- | @since 1.0.11.0 +instance MonoFunctor (Par1 a) +-- | @since 1.0.11.0 +instance MonoFunctor (U1 a) +-- | @since 1.0.11.0 +instance MonoFunctor (V1 a) +-- | @since 1.0.11.0 +instance MonoFunctor (Proxy a) instance U.Unbox a => MonoFunctor (U.Vector a) where omap = U.map {-# INLINE omap #-} instance VS.Storable a => MonoFunctor (VS.Vector a) where omap = VS.map {-# INLINE omap #-} +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance MonoFunctor (VSC.Vector a) +#endif +-- | @since 1.0.20.0 +instance MonoFunctor (f a) => MonoFunctor (Reverse f a) where + omap f (Reverse t) = Reverse (omap f t) -- | @'replaceElem' old new@ replaces all @old@ elements with @new@. -- @@ -288,23 +364,13 @@ -- | Map each element of a monomorphic container to a monadic action, -- evaluate these actions from left to right, and ignore the results. -#if MIN_VERSION_base(4,8,0) omapM_ :: Applicative m => (Element mono -> m ()) -> mono -> m () omapM_ = otraverse_ -#else - omapM_ :: Monad m => (Element mono -> m ()) -> mono -> m () - omapM_ f = ofoldr ((>>) . f) (return ()) -#endif {-# INLINE omapM_ #-} -- | 'oforM_' is 'omapM_' with its arguments flipped. -#if MIN_VERSION_base(4,8,0) oforM_ :: Applicative m => mono -> (Element mono -> m ()) -> m () oforM_ = flip omapM_ -#else - oforM_ :: Monad m => mono -> (Element mono -> m ()) -> m () - oforM_ = flip omapM_ -#endif {-# INLINE oforM_ #-} -- | Monadic fold over the elements of a monomorphic container, associating to the left. @@ -322,17 +388,17 @@ -- /See 'Data.NonNull.ofoldMap1' from "Data.NonNull" for a total version of this function./ ofoldMap1Ex :: Semigroup m => (Element mono -> m) -> mono -> m ofoldMap1Ex f = fromMaybe (Prelude.error "Data.MonoTraversable.ofoldMap1Ex") - . getOption . ofoldMap (Option . Just . f) + . ofoldMap (Just . f) -- | Right-associative fold of a monomorphic container with no base element. -- -- Note: this is a partial function. On an empty 'MonoFoldable', it will -- throw an exception. -- - -- /See 'Data.NonNull.ofoldr1Ex' from "Data.NonNull" for a total version of this function./ + -- /See 'Data.NonNull.ofoldr1' from "Data.NonNull" for a total version of this function./ ofoldr1Ex :: (Element mono -> Element mono -> Element mono) -> mono -> Element mono default ofoldr1Ex :: (t a ~ mono, a ~ Element (t a), F.Foldable t) - => (a -> a -> a) -> mono -> a + => (Element mono -> Element mono -> Element mono) -> mono -> Element mono ofoldr1Ex = F.foldr1 {-# INLINE ofoldr1Ex #-} @@ -342,10 +408,10 @@ -- Note: this is a partial function. On an empty 'MonoFoldable', it will -- throw an exception. -- - -- /See 'Data.NonNull.ofoldl1Ex'' from "Data.NonNull" for a total version of this function./ + -- /See 'Data.NonNull.ofoldl1'' from "Data.NonNull" for a total version of this function./ ofoldl1Ex' :: (Element mono -> Element mono -> Element mono) -> mono -> Element mono default ofoldl1Ex' :: (t a ~ mono, a ~ Element (t a), F.Foldable t) - => (a -> a -> a) -> mono -> a + => (Element mono -> Element mono -> Element mono) -> mono -> Element mono ofoldl1Ex' = F.foldl1 {-# INLINE ofoldl1Ex' #-} @@ -364,7 +430,7 @@ -- Note: this is a partial function. On an empty 'MonoFoldable', it will -- throw an exception. -- - -- /See 'Data.NonNull.last from "Data.NonNull" for a total version of this function./ + -- /See 'Data.NonNull.last' from "Data.NonNull" for a total version of this function./ lastEx :: mono -> Element mono lastEx = ofoldl1Ex' (flip const) {-# INLINE lastEx #-} @@ -385,7 +451,7 @@ -- Note: this is a partial function. On an empty 'MonoFoldable', it will -- throw an exception. -- - -- /See 'Data.NonNull.maximiumBy' from "Data.NonNull" for a total version of this function./ + -- /See 'Data.NonNull.maximumBy' from "Data.NonNull" for a total version of this function./ maximumByEx :: (Element mono -> Element mono -> Ordering) -> mono -> Element mono maximumByEx f = ofoldl1Ex' go @@ -413,6 +479,16 @@ _ -> x {-# INLINE minimumByEx #-} + -- | Checks if the monomorphic container includes the supplied element. + oelem :: Eq (Element mono) => Element mono -> mono -> Bool + oelem e = List.elem e . otoList + {-# INLINE [0] oelem #-} + + -- | Checks if the monomorphic container does not include the supplied element. + onotElem :: Eq (Element mono) => Element mono -> mono -> Bool + onotElem e = List.notElem e . otoList + {-# INLINE [0] onotElem #-} + instance MonoFoldable S.ByteString where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = S.foldr @@ -422,25 +498,18 @@ oany = S.any onull = S.null olength = S.length + oelem = S.elem + onotElem = S.notElem omapM_ f (Unsafe.PS fptr offset len) = do let start = Unsafe.unsafeForeignPtrToPtr fptr `plusPtr` offset end = start `plusPtr` len loop ptr | ptr >= end = evil (touchForeignPtr fptr) `seq` -#if MIN_VERSION_base(4,8,0) pure () -#else - return () -#endif | otherwise = -#if MIN_VERSION_base(4,8,0) f (evil (peek ptr)) *> loop (ptr `plusPtr` 1) -#else - f (evil (peek ptr)) >> - loop (ptr `plusPtr` 1) -#endif loop start where #if MIN_VERSION_bytestring(0,10,6) @@ -468,6 +537,8 @@ {-# INLINE headEx #-} {-# INLINE lastEx #-} {-# INLINE unsafeHead #-} + {-# INLINE oelem #-} + {-# INLINE onotElem #-} {-# RULES "strict ByteString: ofoldMap = concatMap" ofoldMap = S.concatMap #-} instance MonoFoldable L.ByteString where @@ -484,6 +555,9 @@ ofoldl1Ex' = L.foldl1' headEx = L.head lastEx = L.last + oelem = L.elem + onotElem = L.notElem + {-# INLINE ofoldMap #-} {-# INLINE ofoldr #-} {-# INLINE ofoldl' #-} @@ -497,6 +571,8 @@ {-# INLINE ofoldl1Ex' #-} {-# INLINE headEx #-} {-# INLINE lastEx #-} + {-# INLINE oelem #-} + {-# INLINE onotElem #-} {-# RULES "lazy ByteString: ofoldMap = concatMap" ofoldMap = L.concatMap #-} instance MonoFoldable T.Text where @@ -578,11 +654,7 @@ | i Prelude.<= 0 = GT | otherwise = ocompareLength xs (i - 1) instance MonoFoldable (Maybe a) where -#if MIN_VERSION_base(4,8,0) omapM_ _ Nothing = pure () -#else - omapM_ _ Nothing = return () -#endif omapM_ f (Just x) = f x {-# INLINE omapM_ #-} instance MonoFoldable (Tree a) @@ -594,10 +666,14 @@ instance MonoFoldable (ViewL a) instance MonoFoldable (ViewR a) instance MonoFoldable (IntMap a) +#if !MIN_VERSION_base(4,16,0) instance MonoFoldable (Option a) +#endif instance MonoFoldable (NonEmpty a) instance MonoFoldable (Identity a) -instance MonoFoldable (Map k v) +instance MonoFoldable (Map k v) where + olength = Map.size + {-# INLINE olength #-} instance MonoFoldable (HashMap k v) instance MonoFoldable (Vector a) where ofoldr = V.foldr @@ -629,7 +705,13 @@ {-# INLINE unsafeHead #-} {-# INLINE maximumByEx #-} {-# INLINE minimumByEx #-} -instance MonoFoldable (Set e) +instance Ord e => MonoFoldable (Set e) where + olength = Set.size + oelem = Set.member + onotElem = Set.notMember + {-# INLINE olength #-} + {-# INLINE oelem #-} + {-# INLINE onotElem #-} instance MonoFoldable (HashSet e) instance U.Unbox a => MonoFoldable (U.Vector a) where @@ -696,6 +778,39 @@ {-# INLINE unsafeHead #-} {-# INLINE maximumByEx #-} {-# INLINE minimumByEx #-} +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance MonoFoldable (VSC.Vector a) where + ofoldr = VSC.foldr + ofoldl' = VSC.foldl' + otoList = VSC.toList + oall = VSC.all + oany = VSC.any + onull = VSC.null + olength = VSC.length + ofoldr1Ex = VSC.foldr1 + ofoldl1Ex' = VSC.foldl1' + headEx = VSC.head + lastEx = VSC.last + unsafeHead = VSC.unsafeHead + unsafeLast = VSC.unsafeLast + maximumByEx = VSC.maximumBy + minimumByEx = VSC.minimumBy + {-# INLINE ofoldr #-} + {-# INLINE ofoldl' #-} + {-# INLINE otoList #-} + {-# INLINE oall #-} + {-# INLINE oany #-} + {-# INLINE onull #-} + {-# INLINE olength #-} + {-# INLINE ofoldr1Ex #-} + {-# INLINE ofoldl1Ex' #-} + {-# INLINE headEx #-} + {-# INLINE lastEx #-} + {-# INLINE unsafeHead #-} + {-# INLINE maximumByEx #-} + {-# INLINE minimumByEx #-} +#endif instance MonoFoldable (Either a b) where ofoldMap f = ofoldr (mappend . f) mempty ofoldr f b (Right a) = f a b @@ -716,11 +831,7 @@ ofoldr1Ex _ (Right x) = x ofoldl1Ex' _ (Left _) = Prelude.error "ofoldl1Ex' on Either" ofoldl1Ex' _ (Right x) = x -#if MIN_VERSION_base(4,8,0) omapM_ _ (Left _) = pure () -#else - omapM_ _ (Left _) = return () -#endif omapM_ f (Right x) = f x {-# INLINE ofoldMap #-} {-# INLINE ofoldr #-} @@ -736,12 +847,41 @@ instance MonoFoldable (a, b) instance MonoFoldable (Const m a) instance F.Foldable f => MonoFoldable (MaybeT f a) +#if !MIN_VERSION_transformers(0,6,0) instance F.Foldable f => MonoFoldable (ListT f a) +#endif instance F.Foldable f => MonoFoldable (IdentityT f a) instance F.Foldable f => MonoFoldable (WriterT w f a) instance F.Foldable f => MonoFoldable (Strict.WriterT w f a) instance (F.Foldable f, F.Foldable g) => MonoFoldable (Compose f g a) instance (F.Foldable f, F.Foldable g) => MonoFoldable (Product f g a) +-- | @since 1.0.11.0 +instance (F.Foldable f, F.Foldable g) => MonoFoldable ((f :.: g) a) +-- | @since 1.0.11.0 +instance (F.Foldable f, F.Foldable g) => MonoFoldable ((f :*: g) a) +-- | @since 1.0.11.0 +instance (F.Foldable f, F.Foldable g) => MonoFoldable ((f :+: g) a) +-- | @since 1.0.11.0 +instance MonoFoldable (K1 i c a) +-- | @since 1.0.11.0 +instance F.Foldable f => MonoFoldable (M1 i c f a) +-- | @since 1.0.11.0 +instance F.Foldable f => MonoFoldable (Rec1 f a) +-- | @since 1.0.11.0 +instance MonoFoldable (Par1 a) +-- | @since 1.0.11.0 +instance MonoFoldable (U1 a) +-- | @since 1.0.11.0 +instance MonoFoldable (V1 a) +-- | @since 1.0.11.0 +instance MonoFoldable (Proxy a) +-- | @since 1.0.20.0 +instance MonoFoldable (f a) => MonoFoldable (Reverse f a) where + ofoldMap f (Reverse t) = getDual (ofoldMap (Dual . f) t) + ofoldr f z (Reverse t) = ofoldl' (flip f) z t + ofoldl' f z (Reverse t) = ofoldr (flip f) z t + ofoldr1Ex f (Reverse t) = ofoldl1Ex' (flip f) t + ofoldl1Ex' f (Reverse t) = ofoldr1Ex (flip f) t -- | Safe version of 'headEx'. -- @@ -775,14 +915,14 @@ -- | Are __all__ of the elements 'True'? -- --- Since 0.6.0 +-- @since 0.6.0 oand :: (Element mono ~ Bool, MonoFoldable mono) => mono -> Bool oand = oall id {-# INLINE oand #-} -- | Are __any__ of the elements 'True'? -- --- Since 0.6.0 +-- @since 0.6.0 oor :: (Element mono ~ Bool, MonoFoldable mono) => mono -> Bool oor = oany id {-# INLINE oor #-} @@ -817,33 +957,10 @@ -- | Perform all actions in the given container -- -- @since 1.0.0 -#if MIN_VERSION_base(4,8,0) osequence_ :: (Applicative m, MonoFoldable mono, Element mono ~ (m ())) => mono -> m () -#else -osequence_ :: (Monad m, MonoFoldable mono, Element mono ~ (m ())) => mono -> m () -#endif osequence_ = omapM_ id {-# INLINE osequence_ #-} --- | Checks if the monomorphic container includes the supplied element. -oelem :: (MonoFoldable mono, Eq (Element mono)) => Element mono -> mono -> Bool -oelem e = List.elem e . otoList -{-# INLINE [0] oelem #-} - --- | Checks if the monomorphic container does not include the supplied element. -onotElem :: (MonoFoldable mono, Eq (Element mono)) => Element mono -> mono -> Bool -onotElem e = List.notElem e . otoList -{-# INLINE [0] onotElem #-} - -{-# RULES "strict ByteString elem" oelem = S.elem #-} -{-# RULES "strict ByteString notElem" oelem = S.notElem #-} - -{-# RULES "lazy ByteString elem" oelem = L.elem #-} -{-# RULES "lazy ByteString notElem" oelem = L.notElem #-} - -{-# RULES "Set elem" forall (k :: Ord k => k). oelem k = Set.member k #-} -{-# RULES "Set notElem" forall (k :: Ord k => k). oelem k = Set.notMember k #-} - -- | Get the minimum element of a monomorphic container. -- -- Note: this is a partial function. On an empty 'MonoFoldable', it will @@ -932,6 +1049,9 @@ {-# INLINE minimumByMay #-} -- | Monomorphic containers that can be traversed from left to right. +-- +-- NOTE: Due to limitations with the role system, GHC is yet unable to provide newtype-derivation of +-- 'MonoTraversable'. See . class (MonoFunctor mono, MonoFoldable mono) => MonoTraversable mono where -- | Map each element of a monomorphic container to an action, -- evaluate these actions from left to right, and @@ -943,45 +1063,23 @@ -- | Map each element of a monomorphic container to a monadic action, -- evaluate these actions from left to right, and -- collect the results. -#if MIN_VERSION_base(4,8,0) omapM :: Applicative m => (Element mono -> m (Element mono)) -> mono -> m mono omapM = otraverse -#else - omapM :: Monad m => (Element mono -> m (Element mono)) -> mono -> m mono - default omapM :: (Traversable t, mono ~ t a, a ~ Element mono, Monad m) => (Element mono -> m (Element mono)) -> mono -> m mono - omapM = mapM -#endif {-# INLINE otraverse #-} {-# INLINE omapM #-} instance MonoTraversable S.ByteString where otraverse f = fmap S.pack . traverse f . S.unpack {-# INLINE otraverse #-} -#if !MIN_VERSION_base(4,8,0) - omapM f = liftM S.pack . mapM f . S.unpack - {-# INLINE omapM #-} -#endif instance MonoTraversable L.ByteString where otraverse f = fmap L.pack . traverse f . L.unpack {-# INLINE otraverse #-} -#if !MIN_VERSION_base(4,8,0) - omapM f = liftM L.pack . mapM f . L.unpack - {-# INLINE omapM #-} -#endif instance MonoTraversable T.Text where otraverse f = fmap T.pack . traverse f . T.unpack {-# INLINE otraverse #-} -#if !MIN_VERSION_base(4,8,0) - omapM f = liftM T.pack . mapM f . T.unpack - {-# INLINE omapM #-} -#endif instance MonoTraversable TL.Text where otraverse f = fmap TL.pack . traverse f . TL.unpack {-# INLINE otraverse #-} -#if !MIN_VERSION_base(4,8,0) - omapM f = liftM TL.pack . mapM f . TL.unpack - {-# INLINE omapM #-} -#endif instance MonoTraversable [a] instance MonoTraversable (Maybe a) instance MonoTraversable (Tree a) @@ -989,7 +1087,9 @@ instance MonoTraversable (ViewL a) instance MonoTraversable (ViewR a) instance MonoTraversable (IntMap a) +#if !MIN_VERSION_base(4,16,0) instance MonoTraversable (Option a) +#endif instance MonoTraversable (NonEmpty a) instance MonoTraversable (Identity a) instance MonoTraversable (Map k v) @@ -998,44 +1098,60 @@ instance U.Unbox a => MonoTraversable (U.Vector a) where -- FIXME do something more efficient otraverse f = fmap U.fromList . traverse f . U.toList -#if MIN_VERSION_base(4,8,0) omapM = otraverse -#else - omapM = U.mapM -#endif {-# INLINE otraverse #-} {-# INLINE omapM #-} instance VS.Storable a => MonoTraversable (VS.Vector a) where -- FIXME do something more efficient otraverse f = fmap VS.fromList . traverse f . VS.toList -#if MIN_VERSION_base(4,8,0) omapM = otraverse -#else - omapM = VS.mapM -#endif {-# INLINE otraverse #-} {-# INLINE omapM #-} +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance MonoTraversable (VSC.Vector a) +#endif instance MonoTraversable (Either a b) where otraverse _ (Left a) = pure (Left a) otraverse f (Right b) = fmap Right (f b) -#if MIN_VERSION_base(4,8,0) omapM _ (Left a) = pure (Left a) omapM f (Right b) = fmap Right (f b) -#else - omapM _ (Left a) = return (Left a) - omapM f (Right b) = liftM Right (f b) -#endif {-# INLINE otraverse #-} {-# INLINE omapM #-} instance MonoTraversable (a, b) instance MonoTraversable (Const m a) instance Traversable f => MonoTraversable (MaybeT f a) +#if !MIN_VERSION_transformers(0,6,0) instance Traversable f => MonoTraversable (ListT f a) +#endif instance Traversable f => MonoTraversable (IdentityT f a) instance Traversable f => MonoTraversable (WriterT w f a) instance Traversable f => MonoTraversable (Strict.WriterT w f a) instance (Traversable f, Traversable g) => MonoTraversable (Compose f g a) instance (Traversable f, Traversable g) => MonoTraversable (Product f g a) +-- | @since 1.0.11.0 +instance (Traversable f, Traversable g) => MonoTraversable ((f :.: g) a) +-- | @since 1.0.11.0 +instance (Traversable f, Traversable g) => MonoTraversable ((f :*: g) a) +-- | @since 1.0.11.0 +instance (Traversable f, Traversable g) => MonoTraversable ((f :+: g) a) +-- | @since 1.0.11.0 +instance MonoTraversable (K1 i c a) +-- | @since 1.0.11.0 +instance Traversable f => MonoTraversable (M1 i c f a) +-- | @since 1.0.11.0 +instance Traversable f => MonoTraversable (Rec1 f a) +-- | @since 1.0.11.0 +instance MonoTraversable (Par1 a) +-- | @since 1.0.11.0 +instance MonoTraversable (U1 a) +-- | @since 1.0.11.0 +instance MonoTraversable (V1 a) +-- | @since 1.0.11.0 +instance MonoTraversable (Proxy a) +-- | @since 1.0.20.0 +instance (MonoTraversable (f a)) => MonoTraversable (Reverse f a) where + otraverse f (Reverse t) = (fmap Reverse . forwards) (otraverse (Backwards . f) t) -- | 'ofor' is 'otraverse' with its arguments flipped. ofor :: (MonoTraversable mono, Applicative f) => mono -> (Element mono -> f (Element mono)) -> f mono @@ -1043,11 +1159,7 @@ {-# INLINE ofor #-} -- | 'oforM' is 'omapM' with its arguments flipped. -#if MIN_VERSION_base(4,8,0) oforM :: (MonoTraversable mono, Applicative f) => mono -> (Element mono -> f (Element mono)) -> f mono -#else -oforM :: (MonoTraversable mono, Monad f) => mono -> (Element mono -> f (Element mono)) -> f mono -#endif oforM = flip omapM {-# INLINE oforM #-} @@ -1057,7 +1169,7 @@ -- expected type. It is provided mainly for integration with the @foldl@ -- package, to be used in conjunction with @purely@. -- --- Since 0.3.1 +-- @since 0.3.1 ofoldlUnwrap :: MonoFoldable mono => (x -> Element mono -> x) -> x -> (x -> b) -> mono -> b ofoldlUnwrap f x unwrap mono = unwrap (ofoldl' f x mono) @@ -1067,7 +1179,7 @@ -- Similar to 'foldlUnwrap', but allows monadic actions. To be used with -- @impurely@ from @foldl@. -- --- Since 0.3.1 +-- @since 0.3.1 ofoldMUnwrap :: (Monad m, MonoFoldable mono) => (x -> Element mono -> m x) -> m x -> (x -> m b) -> mono -> m b ofoldMUnwrap f mx unwrap mono = do @@ -1100,17 +1212,27 @@ instance MonoPointed L.ByteString where opoint = L.singleton {-# INLINE opoint #-} +-- | @since 1.0.16.0 +instance MonoPointed B.Builder where + opoint = B.word8 + {-# INLINE opoint #-} instance MonoPointed T.Text where opoint = T.singleton {-# INLINE opoint #-} instance MonoPointed TL.Text where opoint = TL.singleton {-# INLINE opoint #-} +-- | @since 1.0.18.0 +instance MonoPointed TB.Builder where + opoint = TB.singleton + {-# INLINE opoint #-} -- Applicative instance MonoPointed [a] instance MonoPointed (Maybe a) +#if !MIN_VERSION_base(4,16,0) instance MonoPointed (Option a) +#endif instance MonoPointed (NonEmpty a) instance MonoPointed (Identity a) instance MonoPointed (Vector a) @@ -1120,7 +1242,9 @@ instance Monoid a => MonoPointed (a, b) instance Monoid m => MonoPointed (Const m a) instance Monad m => MonoPointed (WrappedMonad m a) +#if !MIN_VERSION_transformers(0,6,0) instance Applicative m => MonoPointed (ListT m a) +#endif instance Applicative m => MonoPointed (IdentityT m a) instance Arrow a => MonoPointed (WrappedArrow a b c) instance (Monoid w, Applicative m) => MonoPointed (WriterT w m a) @@ -1129,6 +1253,20 @@ instance MonoPointed (ContT r m a) instance (Applicative f, Applicative g) => MonoPointed (Compose f g a) instance (Applicative f, Applicative g) => MonoPointed (Product f g a) +-- | @since 1.0.11.0 +instance (Applicative f, Applicative g) => MonoPointed ((f :.: g) a) +-- | @since 1.0.11.0 +instance (Applicative f, Applicative g) => MonoPointed ((f :*: g) a) +-- | @since 1.0.11.0 +instance Applicative f => MonoPointed (M1 i c f a) +-- | @since 1.0.11.0 +instance Applicative f => MonoPointed (Rec1 f a) +-- | @since 1.0.11.0 +instance MonoPointed (Par1 a) +-- | @since 1.0.11.0 +instance MonoPointed (U1 a) +-- | @since 1.0.11.0 +instance MonoPointed (Proxy a) -- Not Applicative instance MonoPointed (Seq a) where @@ -1140,6 +1278,10 @@ instance VS.Storable a => MonoPointed (VS.Vector a) where opoint = VS.singleton {-# INLINE opoint #-} +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance MonoPointed (VSC.Vector a) +#endif instance MonoPointed (Either a b) where opoint = Right {-# INLINE opoint #-} @@ -1176,6 +1318,10 @@ instance MonoPointed (Tree a) where opoint a = Node a [] {-# INLINE opoint #-} +-- | @since 1.0.11.0 +instance (Applicative f, Applicative g) => MonoPointed ((f :+: g) a) where + opoint = R1 . pure + {-# INLINE opoint #-} -- | Typeclass for monomorphic containers where it is always okay to @@ -1207,7 +1353,7 @@ instance MonoComonad (ViewL a) where oextract ~(x :< _) = x {-# INLINE oextract #-} - oextend f w@ ~(_ :< xxs) = + oextend f w@(~(_ :< xxs)) = f w :< case Seq.viewl xxs of EmptyL -> Seq.empty xs -> case oextend f xs of @@ -1217,7 +1363,7 @@ instance MonoComonad (ViewR a) where oextract ~(_ :> x) = x {-# INLINE oextract #-} - oextend f w@ ~(xxs :> _) = + oextend f w@(~(xxs :> _)) = (case Seq.viewr xxs of EmptyR -> Seq.empty xs -> case oextend f xs of @@ -1246,6 +1392,10 @@ instance GrowingAppend (V.Vector a) instance U.Unbox a => GrowingAppend (U.Vector a) instance VS.Storable a => GrowingAppend (VS.Vector a) +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance GrowingAppend (VSC.Vector a) +#endif instance GrowingAppend S.ByteString instance GrowingAppend L.ByteString instance GrowingAppend T.Text @@ -1278,3 +1428,127 @@ ointercalate x = T.intercalate x . otoList #-} {-# RULES "intercalate LText" forall x. ointercalate x = TL.intercalate x . otoList #-} + +-- | Provides a `MonoFoldable`, `MonoFunctor` or `MonoPointed` for an arbitrary +-- `F.Foldable`, `Functor` or `Applicative`. +-- +-- Useful for, e.g., passing a `F.Foldable` type you don't own into a +-- function that expects a `MonoFoldable`. +-- +-- > // package A +-- > data MyList a = MyList [a] deriving Foldable +-- > +-- > // package B +-- > process :: MonoFoldable mono => mono -> IO () +-- > +-- > // package C +-- > process (WrappedPoly (MyList [])) +-- +-- @since 1.0.13.0 +newtype WrappedPoly f a = WrappedPoly { unwrapPoly :: f a } + deriving newtype (F.Foldable, Functor, Applicative, Monad) + +type instance Element (WrappedPoly f a) = a +instance F.Foldable f => MonoFoldable (WrappedPoly f a) +instance Functor f => MonoFunctor (WrappedPoly f a) +instance Applicative f => MonoPointed (WrappedPoly f a) + + +-- | Provides a `F.Foldable` for an arbitrary `MonoFoldable`. +-- +-- @since 1.0.14.0 +data WrappedMono mono a where + WrappedMono :: Element mono ~ a => mono -> WrappedMono mono a + +-- | Unwraps a `WrappedMono`. +-- +-- @since 1.0.14.0 +unwrapMono :: WrappedMono mono a -> mono +unwrapMono (WrappedMono mono) = mono +{-# INLINE unwrapMono #-} + +type instance Element (WrappedMono mono a) = Element mono + +instance MonoFoldable mono => MonoFoldable (WrappedMono mono a) where + ofoldMap f = ofoldMap f . unwrapMono + {-# INLINE ofoldMap #-} + ofoldr f z = ofoldr f z . unwrapMono + {-# INLINE ofoldr #-} + ofoldl' f z = ofoldl' f z . unwrapMono + {-# INLINE ofoldl' #-} + otoList = otoList . unwrapMono + {-# INLINE otoList #-} + oall f = oall f . unwrapMono + {-# INLINE oall #-} + oany f = oany f . unwrapMono + {-# INLINE oany #-} + onull = onull . unwrapMono + {-# INLINE onull #-} + olength = olength . unwrapMono + {-# INLINE olength #-} + olength64 = olength64 . unwrapMono + {-# INLINE olength64 #-} + ocompareLength mono i = ocompareLength (unwrapMono mono) i + {-# INLINE ocompareLength #-} + otraverse_ f = otraverse_ f . unwrapMono + {-# INLINE otraverse_ #-} + ofor_ mono f = ofor_ (unwrapMono mono) f + {-# INLINE ofor_ #-} + omapM_ f = omapM_ f . unwrapMono + {-# INLINE omapM_ #-} + oforM_ mono f = oforM_ (unwrapMono mono) f + {-# INLINE oforM_ #-} + ofoldlM f z = ofoldlM f z . unwrapMono + {-# INLINE ofoldlM #-} + ofoldMap1Ex f = ofoldMap1Ex f . unwrapMono + {-# INLINE ofoldMap1Ex #-} + ofoldr1Ex f = ofoldr1Ex f . unwrapMono + {-# INLINE ofoldr1Ex #-} + ofoldl1Ex' f = ofoldl1Ex' f . unwrapMono + {-# INLINE ofoldl1Ex' #-} + headEx = headEx . unwrapMono + {-# INLINE headEx #-} + lastEx = lastEx . unwrapMono + {-# INLINE lastEx #-} + unsafeHead = unsafeHead . unwrapMono + {-# INLINE unsafeHead #-} + unsafeLast = unsafeLast . unwrapMono + {-# INLINE unsafeLast #-} + maximumByEx f = maximumByEx f . unwrapMono + {-# INLINE maximumByEx #-} + minimumByEx f = minimumByEx f . unwrapMono + {-# INLINE minimumByEx #-} + oelem a = oelem a . unwrapMono + {-# INLINE oelem #-} + onotElem a = onotElem a . unwrapMono + {-# INLINE onotElem #-} + +instance MonoFunctor mono => MonoFunctor (WrappedMono mono a) where + omap f (WrappedMono mono) = WrappedMono (omap f mono) + {-# INLINE omap #-} + +instance (MonoPointed mono, Element mono ~ a) => MonoPointed (WrappedMono mono a) where + opoint a = WrappedMono (opoint a) + {-# INLINE opoint #-} + +instance MonoFoldable mono => F.Foldable (WrappedMono mono) where + foldr f zero (WrappedMono mono) = ofoldr f zero mono + {-# INLINE foldr #-} + foldMap f (WrappedMono mono) = ofoldMap f mono + {-# INLINE foldMap #-} + foldl' f z (WrappedMono mono) = ofoldl' f z mono + {-# INLINE foldl' #-} + foldl1 f (WrappedMono mono) = ofoldl1Ex' f mono + {-# INLINE foldl1 #-} + toList (WrappedMono mono) = otoList mono + {-# INLINE toList #-} + null (WrappedMono mono) = onull mono + {-# INLINE null #-} + length (WrappedMono mono) = olength mono + {-# INLINE length #-} + elem a (WrappedMono mono) = oelem a mono + {-# INLINE elem #-} + maximum (WrappedMono mono) = maximumEx mono + {-# INLINE maximum #-} + minimum (WrappedMono mono) = minimumEx mono + {-# INLINE minimum #-} diff --git a/src/Data/MonoTraversable/Unprefixed.hs b/src/Data/MonoTraversable/Unprefixed.hs --- a/src/Data/MonoTraversable/Unprefixed.hs +++ b/src/Data/MonoTraversable/Unprefixed.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | The functions in "Data.MonoTraversable" are all prefixed with the letter -- @o@ to avoid conflicts with their polymorphic counterparts. This module -- exports the same identifiers without the prefix, for all cases where the @@ -14,7 +15,6 @@ import Data.Int (Int64) import Data.MonoTraversable -import Data.Semigroup (Semigroup) import Data.Monoid (Monoid) import Control.Applicative (Applicative) @@ -93,25 +93,15 @@ -- | Synonym for 'omapM_' -- -- @since 1.0.0 -#if MIN_VERSION_base(4,8,0) mapM_ :: (MonoFoldable mono, Applicative m) => (Element mono -> m ()) -> mono -> m () -#else -mapM_ :: (MonoFoldable mono, Monad m) - => (Element mono -> m ()) -> mono -> m () -#endif mapM_ = omapM_ -- | Synonym for 'oforM_' -- -- @since 1.0.0 -#if MIN_VERSION_base(4,8,0) forM_ :: (MonoFoldable mono, Applicative m) => mono -> (Element mono -> m ()) -> m () -#else -forM_ :: (MonoFoldable mono, Monad m) - => mono -> (Element mono -> m ()) -> m () -#endif forM_ = oforM_ -- | Synonym for 'ofoldlM' @@ -227,9 +217,5 @@ -- | Synonym for 'osequence_' -- -- @since 1.0.0 -#if MIN_VERSION_base(4,8,0) sequence_ :: (Applicative m, MonoFoldable mono, Element mono ~ (m ())) => mono -> m () -#else -sequence_ :: (Monad m, MonoFoldable mono, Element mono ~ (m ())) => mono -> m () -#endif sequence_ = osequence_ diff --git a/src/Data/NonNull.hs b/src/Data/NonNull.hs --- a/src/Data/NonNull.hs +++ b/src/Data/NonNull.hs @@ -16,6 +16,7 @@ , nonNull , toNullable , fromNonEmpty + , toNonEmpty , ncons , nuncons , splitFirst @@ -36,21 +37,18 @@ , minimumBy , (<|) , toMinList + , mapNonNull , GrowingAppend ) where import Prelude hiding (head, tail, init, last, reverse, seq, filter, replicate, maximum, minimum) import Control.Arrow (second) import Control.Exception.Base (Exception, throw) -#if !MIN_VERSION_base(4,8,0) -import Control.Monad (liftM) -#endif import Data.Data import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.MonoTraversable import Data.Sequences -import Data.Semigroup (Semigroup (..)) import Control.Monad.Trans.State.Strict (evalState, state) data NullError = NullError String deriving (Show, Typeable) @@ -68,10 +66,7 @@ instance MonoTraversable mono => MonoTraversable (NonNull mono) where otraverse f (NonNull x) = fmap NonNull (otraverse f x) {-# INLINE otraverse #-} -#if !MIN_VERSION_base(4,8,0) - omapM f (NonNull x) = liftM NonNull (omapM f x) - {-# INLINE omapM #-} -#endif + instance GrowingAppend mono => GrowingAppend (NonNull mono) instance (Semigroup mono, GrowingAppend mono) => Semigroup (NonNull mono) where @@ -131,6 +126,12 @@ fromNonEmpty = impureNonNull . fromList . NE.toList {-# INLINE fromNonEmpty #-} +-- | __Safely__ convert from a 'NonNull' container to a 'NonEmpty' list. +-- +-- @since 1.0.15.0 +toNonEmpty :: MonoFoldable mono => NonNull mono -> NE.NonEmpty (Element mono) +toNonEmpty = NE.fromList . otoList + -- | Specializes 'fromNonEmpty' to lists only. toMinList :: NE.NonEmpty a -> NonNull [a] toMinList = fromNonEmpty @@ -144,11 +145,11 @@ -- -- * if you don't need to cons, use 'fromNullable' or 'nonNull' if you can create your structure in one go. -- * if you need to cons, you might be able to start off with an efficient data structure such as a 'NonEmpty' List. --- 'fronNonEmpty' will convert that to your data structure using the structure's fromList function. +-- 'fromNonEmpty' will convert that to your data structure using the structure's fromList function. ncons :: SemiSequence seq => Element seq -> seq -> NonNull seq ncons x xs = nonNull $ cons x xs --- | Extract the first element of a sequnce and the rest of the non-null sequence if it exists. +-- | Extract the first element of a sequence and the rest of the non-null sequence if it exists. nuncons :: IsSequence seq => NonNull seq -> (Element seq, Maybe (NonNull seq)) nuncons xs = second fromNullable @@ -161,17 +162,17 @@ fromMaybe (error "Data.NonNull.splitFirst: data structure is null, it should be non-null") $ uncons (toNullable xs) --- | Equivalent to @"Data.Sequence".'Data.Sequence.filter'@, +-- | Equivalent to @"Data.Sequences".'Data.Sequences.filter'@, -- but works on non-nullable sequences. nfilter :: IsSequence seq => (Element seq -> Bool) -> NonNull seq -> seq nfilter f = filter f . toNullable --- | Equivalent to @"Data.Sequence".'Data.Sequence.filterM'@, +-- | Equivalent to @"Data.Sequences".'Data.Sequences.filterM'@, -- but works on non-nullable sequences. nfilterM :: (Monad m, IsSequence seq) => (Element seq -> m Bool) -> NonNull seq -> m seq nfilterM f = filterM f . toNullable --- | Equivalent to @"Data.Sequence".'Data.Sequence.replicate'@ +-- | Equivalent to @"Data.Sequences".'Data.Sequences.replicate'@ -- -- @i@ must be @> 0@ -- @@ -348,3 +349,20 @@ -> Element mono minimumBy cmp = minimumByEx cmp . toNullable {-# INLINE minimumBy #-} + +-- | 'fmap' over the underlying container in a 'NonNull'. +-- +-- @since 1.0.6.0 + +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'ncons' 1 [2, 3 :: Int] +-- > 'mapNonNull' 'show' xs +-- 'NonNull' {toNullable = [\"1\",\"2\",\"3\"]} +-- @ +mapNonNull :: (Functor f, MonoFoldable (f b)) + => (a -> b) + -> NonNull (f a) + -> NonNull (f b) +mapNonNull f = impureNonNull . fmap f . toNullable diff --git a/src/Data/Sequences.hs b/src/Data/Sequences.hs --- a/src/Data/Sequences.hs +++ b/src/Data/Sequences.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -5,17 +6,18 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} -- | Abstractions over sequential data structures, like lists and vectors. module Data.Sequences where -import Data.Maybe (fromJust, isJust) -import Data.Monoid (Monoid, mconcat, mempty) +import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Monoid (Monoid, mconcat, mempty, (<>)) import Data.MonoTraversable import Data.Int (Int64, Int) import qualified Data.List as List import qualified Data.List.Split as List import qualified Control.Monad (filterM, replicateM) -import Prelude (Bool (..), Monad (..), Maybe (..), Ordering (..), Ord (..), Eq (..), Functor (..), fromIntegral, otherwise, (-), fst, snd, Integral, ($), flip, maybe, error) +import Prelude (Bool (..), Monad (..), Maybe (..), Ordering (..), Ord (..), Eq (..), Functor (..), fromIntegral, otherwise, (-), fst, snd, Integral, ($), flip, maybe, error, (||)) import Data.Char (Char, isSpace) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -28,6 +30,11 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Storable as VS +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VSC +#else +{-# DependencyDeprecation "Support for vector < 0.13.2 will be removed when GHC 9.12 reaches Stackage nightly. Please upgrade to vector >= 0.13.2." #-} +#endif import Data.String (IsString) import qualified Data.List.NonEmpty as NE import qualified Data.ByteString.Unsafe as SU @@ -42,7 +49,7 @@ -- | 'SemiSequence' was created to share code between 'IsSequence' and 'NonNull'. -- -- @Semi@ means 'SemiGroup' --- A 'SemiSequence' can accomodate a 'SemiGroup' such as 'NonEmpty' or 'NonNull' +-- A 'SemiSequence' can accommodate a 'SemiGroup' such as 'NonEmpty' or 'NonNull' -- A Monoid should be able to fill out 'IsSequence'. -- -- 'SemiSequence' operations maintain the same type because they all maintain the same number of elements or increase them. @@ -122,7 +129,7 @@ -- > 'singleton' 'a' :: 'Vector' 'Char' -- 'Data.Vector.fromList' "a" -- @ -singleton :: IsSequence seq => Element seq -> seq +singleton :: MonoPointed seq => Element seq -> seq singleton = opoint {-# INLINE singleton #-} @@ -145,8 +152,14 @@ -- However, all the instances define their own fromList fromList = mconcat . fmap singleton - -- below functions change type fron the perspective of NonEmpty + -- | 'lengthIndex' returns the length of a sequence as @'Index' seq@. + -- + -- @since 1.0.2 + lengthIndex :: seq -> Index seq; + lengthIndex = fromIntegral . olength64; + -- below functions change type from the perspective of NonEmpty + -- | 'break' applies a predicate to a sequence, and returns a tuple where -- the first element is the longest prefix (possibly empty) of elements that -- /do not satisfy/ the predicate. The second element of the tuple is the @@ -263,6 +276,19 @@ unsafeDrop :: Index seq -> seq -> seq unsafeDrop = drop + -- | Same as 'drop' but drops from the end of the sequence instead. + -- + -- @ + -- > 'dropEnd' 3 "abcdefg" + -- "abcd" + -- > 'dropEnd' 4 ('fromList' [1,2,3,4,5,6] :: 'Vector' 'Int') + -- fromList [1,2] + -- @ + -- + -- @since 1.0.4.0 + dropEnd :: Index seq -> seq -> seq + dropEnd i s = fst $ splitAt (lengthIndex s - i) s + -- | 'partition' takes a predicate and a sequence and returns the pair of -- sequences of elements which do and do not satisfy the predicate. -- @@ -289,10 +315,10 @@ -- or 'Nothing' if the sequence is empty. -- -- @ - -- > 'uncons' ('fromList' [1,2,3,4] :: 'Vector' 'Int') + -- > 'unsnoc' ('fromList' [1,2,3,4] :: 'Vector' 'Int') -- 'Just' (fromList [1,2,3],4) -- - -- > 'uncons' ([] :: ['Int']) + -- > 'unsnoc' ([] :: ['Int']) -- 'Nothing' -- @ unsnoc :: seq -> Maybe (seq, Element seq) @@ -404,7 +430,7 @@ -- an empty monomorphic container. -- -- @since 1.0.0 - initMay :: IsSequence seq => seq -> Maybe seq + initMay :: seq -> Maybe seq initMay seq | onull seq = Nothing | otherwise = Just (initEx seq) @@ -428,7 +454,9 @@ -- 'Nothing' -- @ index :: seq -> Index seq -> Maybe (Element seq) - index seq' idx = headMay (drop idx seq') + index seq' idx + | idx < 0 = Nothing + | otherwise = headMay (drop idx seq') -- | __Unsafe__ -- @@ -451,6 +479,47 @@ splitWhen :: (Element seq -> Bool) -> seq -> [seq] splitWhen = defaultSplitWhen + -- | Returns all the final segments of 'seq' with the longest first. + -- + -- @ + -- > tails [1,2] + -- [[1,2],[2],[]] + -- > tails [] + -- [[]] + -- @ + -- + -- @since 1.0.17.0 + tails :: seq -> [seq] + tails x = x : maybe mempty tails (tailMay x) + + -- | Return all the initial segments of 'seq' with the shortest first. + -- + -- @ + -- > inits [1,2] + -- [[],[1],[1,2]] + -- > inits [] + -- [[]] + -- @ + -- + -- @since 1.0.17.0 + inits :: seq -> [seq] + inits seq = is seq [seq] + where + is = maybe id (\x -> is x . (x :)) . initMay + + -- | Return all the pairs of inital and final segments of 'seq'. + -- + -- @ + -- > initTails [1,2] + -- [([],[1,2]),([1],[2]),([1,2],[])] + -- > initTails [] + -- [([],[])] + -- @ + -- + -- @since 1.0.17.0 + initTails :: seq -> [(seq,seq)] + initTails seq = List.zip (inits seq) (tails seq) + {-# INLINE fromList #-} {-# INLINE break #-} {-# INLINE span #-} @@ -481,6 +550,9 @@ {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} {-# INLINE splitWhen #-} + {-# INLINE tails #-} + {-# INLINE inits #-} + {-# INLINE initTails #-} -- | Use "Data.List"'s implementation of 'Data.List.find'. defaultFind :: MonoFoldable seq => (Element seq -> Bool) -> seq -> Maybe (Element seq) @@ -558,6 +630,7 @@ instance IsSequence [a] where fromList = id + lengthIndex = List.length filter = List.filter filterM = Control.Monad.filterM break = List.break @@ -585,6 +658,13 @@ (matches, nonMatches) = partition ((== f head) . f) tail groupAllOn _ [] = [] splitWhen = List.splitWhen + tails = List.tails + inits = List.inits + initTails = its id + where + its :: ([a] -> [a]) -> [a] -> [([a],[a])] + its f xs@(y:ys) = (f [], xs) : its (f . (y:)) ys + its f [] = [(f [], [])] {-# INLINE fromList #-} {-# INLINE break #-} {-# INLINE span #-} @@ -603,6 +683,9 @@ {-# INLINE groupBy #-} {-# INLINE groupAllOn #-} {-# INLINE splitWhen #-} + {-# INLINE tails #-} + {-# INLINE inits #-} + {-# INLINE initTails #-} instance SemiSequence (NE.NonEmpty a) where type Index (NE.NonEmpty a) = Int @@ -637,6 +720,7 @@ instance IsSequence S.ByteString where fromList = S.pack + lengthIndex = S.length replicate = S.replicate filter = S.filter break = S.break @@ -681,8 +765,8 @@ {-# INLINE splitWhen #-} index bs i - | i >= S.length bs = Nothing - | otherwise = Just (S.index bs i) + | i < 0 || i >= S.length bs = Nothing + | otherwise = Just (SU.unsafeIndex bs i) indexEx = S.index unsafeIndex = SU.unsafeIndex {-# INLINE index #-} @@ -706,6 +790,7 @@ instance IsSequence T.Text where fromList = T.pack + lengthIndex = T.length replicate i c = T.replicate i (T.singleton c) filter = T.filter break = T.break @@ -715,6 +800,7 @@ splitAt = T.splitAt take = T.take drop = T.drop + dropEnd = T.dropEnd partition = T.partition uncons = T.uncons unsnoc t @@ -743,7 +829,7 @@ {-# INLINE splitWhen #-} index t i - | i >= T.length t = Nothing + | i < 0 || i >= T.length t = Nothing | otherwise = Just (T.index t i) indexEx = T.index unsafeIndex = T.index @@ -768,6 +854,7 @@ instance IsSequence L.ByteString where fromList = L.pack + lengthIndex = L.length replicate = L.replicate filter = L.filter break = L.break @@ -827,6 +914,7 @@ instance IsSequence TL.Text where fromList = TL.pack + lengthIndex = TL.length replicate i c = TL.replicate i (TL.singleton c) filter = TL.filter break = TL.break @@ -886,6 +974,7 @@ instance IsSequence (Seq.Seq a) where fromList = Seq.fromList + lengthIndex = Seq.length replicate = Seq.replicate replicateM = Seq.replicateM filter = Seq.filter @@ -926,15 +1015,19 @@ {-# INLINE tailEx #-} {-# INLINE initEx #-} - index seq' i - | i >= Seq.length seq' = Nothing - | otherwise = Just (Seq.index seq' i) + index = (Seq.!?) indexEx = Seq.index unsafeIndex = Seq.index {-# INLINE index #-} {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} + initTails = its . (,) mempty + where + its x@(is, y Seq.:<| ts) = x : its (is Seq.:|> y, ts) + its x@(_, Seq.Empty) = [x] + {-# INLINE initTails #-} + instance SemiSequence (V.Vector a) where type Index (V.Vector a) = Int reverse = V.reverse @@ -953,6 +1046,7 @@ instance IsSequence (V.Vector a) where fromList = V.fromList + lengthIndex = V.length replicate = V.replicate replicateM = V.replicateM filter = V.filter @@ -1000,15 +1094,91 @@ {-# INLINE unsafeTail #-} {-# INLINE unsafeInit #-} - index v i - | i >= V.length v = Nothing - | otherwise = Just (v V.! i) + index = (V.!?) indexEx = (V.!) unsafeIndex = V.unsafeIndex {-# INLINE index #-} {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} +#if MIN_VERSION_vector(0,13,2) +-- | @since 1.0.21.0 +instance SemiSequence (VSC.Vector a) where + type Index (VSC.Vector a) = Int + reverse = VSC.reverse + find = VSC.find + cons = VSC.cons + snoc = VSC.snoc + + sortBy = vectorSortBy + intersperse = defaultIntersperse + {-# INLINE intersperse #-} + {-# INLINE reverse #-} + {-# INLINE find #-} + {-# INLINE sortBy #-} + {-# INLINE cons #-} + {-# INLINE snoc #-} + +-- | @since 1.0.21.0 +instance IsSequence (VSC.Vector a) where + fromList = VSC.fromList + lengthIndex = VSC.length + replicate = VSC.replicate + replicateM = VSC.replicateM + filter = VSC.filter + filterM = VSC.filterM + break = VSC.break + span = VSC.span + dropWhile = VSC.dropWhile + takeWhile = VSC.takeWhile + splitAt = VSC.splitAt + take = VSC.take + drop = VSC.drop + unsafeTake = VSC.unsafeTake + unsafeDrop = VSC.unsafeDrop + partition = VSC.partition + uncons v + | VSC.null v = Nothing + | otherwise = Just (VSC.head v, VSC.tail v) + unsnoc v + | VSC.null v = Nothing + | otherwise = Just (VSC.init v, VSC.last v) + groupBy = VSC.groupBy + tailEx = VSC.tail + initEx = VSC.init + unsafeTail = VSC.unsafeTail + unsafeInit = VSC.unsafeInit + {-# INLINE fromList #-} + {-# INLINE break #-} + {-# INLINE span #-} + {-# INLINE dropWhile #-} + {-# INLINE takeWhile #-} + {-# INLINE splitAt #-} + {-# INLINE take #-} + {-# INLINE unsafeTake #-} + {-# INLINE drop #-} + {-# INLINE unsafeDrop #-} + {-# INLINE partition #-} + {-# INLINE uncons #-} + {-# INLINE unsnoc #-} + {-# INLINE filter #-} + {-# INLINE filterM #-} + {-# INLINE replicate #-} + {-# INLINE replicateM #-} + {-# INLINE groupBy #-} + {-# INLINE tailEx #-} + {-# INLINE initEx #-} + {-# INLINE unsafeTail #-} + {-# INLINE unsafeInit #-} + + index = (VSC.!?) + indexEx = (VSC.!) + unsafeIndex = VSC.unsafeIndex + {-# INLINE index #-} + {-# INLINE indexEx #-} + {-# INLINE unsafeIndex #-} +#endif + instance U.Unbox a => SemiSequence (U.Vector a) where type Index (U.Vector a) = Int @@ -1027,6 +1197,7 @@ instance U.Unbox a => IsSequence (U.Vector a) where fromList = U.fromList + lengthIndex = U.length replicate = U.replicate replicateM = U.replicateM filter = U.filter @@ -1074,9 +1245,7 @@ {-# INLINE unsafeTail #-} {-# INLINE unsafeInit #-} - index v i - | i >= U.length v = Nothing - | otherwise = Just (v U.! i) + index = (U.!?) indexEx = (U.!) unsafeIndex = U.unsafeIndex {-# INLINE index #-} @@ -1101,6 +1270,7 @@ instance VS.Storable a => IsSequence (VS.Vector a) where fromList = VS.fromList + lengthIndex = VS.length replicate = VS.replicate replicateM = VS.replicateM filter = VS.filter @@ -1148,9 +1318,7 @@ {-# INLINE unsafeTail #-} {-# INLINE unsafeInit #-} - index v i - | i >= VS.length v = Nothing - | otherwise = Just (v VS.! i) + index = (VS.!?) indexEx = (VS.!) unsafeIndex = VS.unsafeIndex {-# INLINE index #-} @@ -1207,7 +1375,7 @@ -- -- @ -- > 'stripPrefix' "foo" "foobar" --- 'Just' "foo" +-- 'Just' "bar" -- > 'stripPrefix' "abc" "foobar" -- 'Nothing' -- @ @@ -1231,6 +1399,61 @@ stripSuffixList :: Eq a => [a] -> [a] -> Maybe [a] stripSuffixList x' y' = fmap reverse (stripPrefix (reverse x') (reverse y')) +-- | 'dropPrefix' drops the given prefix from a sequence. It returns the +-- original sequence if the sequence doesn't start with the given prefix. +-- +-- @ +-- > 'dropPrefix' \"foo\" \"foobar\" +-- \"bar\" +-- > 'dropPrefix' \"abc\" \"foobar\" +-- \"foobar\" +-- @ +-- +-- @since 1.0.7.0 +dropPrefix :: (IsSequence seq, Eq (Element seq)) => seq -> seq -> seq +dropPrefix x y = fromMaybe y (stripPrefix x y) + +-- | 'dropSuffix' drops the given suffix from a sequence. It returns the +-- original sequence if the sequence doesn't end with the given suffix. +-- +-- @ +-- > 'dropSuffix' \"bar\" \"foobar\" +-- \"foo\" +-- > 'dropSuffix' \"abc\" \"foobar\" +-- \"foobar\" +-- @ +-- +-- @since 1.0.7.0 +dropSuffix :: (IsSequence seq, Eq (Element seq)) => seq -> seq -> seq +dropSuffix x y = fromMaybe y (stripSuffix x y) + +-- | 'ensurePrefix' will add a prefix to a sequence if it doesn't +-- exist, and otherwise have no effect. +-- +-- @ +-- > 'ensurePrefix' "foo" "foobar" +-- "foobar" +-- > 'ensurePrefix' "abc" "foobar" +-- "abcfoobar" +-- @ +-- +-- @since 1.0.3 +ensurePrefix :: (Eq (Element seq), IsSequence seq) => seq -> seq -> seq +ensurePrefix prefix seq = if isPrefixOf prefix seq then seq else prefix <> seq + +-- | Append a suffix to a sequence, unless it already has that suffix. +-- +-- @ +-- > 'ensureSuffix' "bar" "foobar" +-- "foobar" +-- > 'ensureSuffix' "abc" "foobar" +-- "foobarabc" +-- @ +-- +-- @since 1.0.3 +ensureSuffix :: (Eq (Element seq), IsSequence seq) => seq -> seq -> seq +ensureSuffix suffix seq = if isSuffixOf suffix seq then seq else seq <> suffix + -- | 'isPrefixOf' takes two sequences and returns 'True' if the first -- sequence is a prefix of the second. isPrefixOf :: (IsSequence seq, Eq (Element seq)) => seq -> seq -> Bool @@ -1379,8 +1602,8 @@ -- > 'sort' [4,3,1,2] -- [1,2,3,4] -- @ -sort :: (IsSequence seq, Ord (Element seq)) => seq -> seq -sort = fromList . V.toList . vectorSort . V.fromList . otoList +sort :: (SemiSequence seq, Ord (Element seq)) => seq -> seq +sort = sortBy compare {-# INLINE [0] sort #-} {-# RULES "strict ByteString sort" sort = S.sort #-} @@ -1399,7 +1622,7 @@ -- @ words :: t -> [t] - -- | Join a list of textual sequences using seperating spaces. + -- | Join a list of textual sequences using separating spaces. -- -- @ -- > 'unwords' ["abc","def","ghi"] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,609 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +import Data.MonoTraversable +import Data.Containers +import Data.Sequences +import qualified Data.Sequence as Seq +import qualified Data.NonNull as NN +import Data.Monoid (mempty, mconcat, (<>)) +import Data.Maybe (fromMaybe) +import qualified Data.List as List + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit ((@?=)) +import Test.QuickCheck hiding (NonEmptyList(..)) +import Test.QuickCheck.Function (pattern Fn) +import qualified Test.QuickCheck.Modifiers as QCM + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as VS +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VSC +#else +{-# MissingTests "Tests for Data.Vector.Strict are disabled due to vector < 0.13.2. Please upgrade vector to >= 0.13.2 to enable these tests." #-} +#endif +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as SG +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Control.Foldl as Foldl +import Data.String (IsString, fromString) + +import Control.Arrow (second) +import Control.Applicative +import Control.Monad.Trans.Writer + +import Prelude (Bool (..), ($), IO, Eq (..), fromIntegral, Ord (..), String, mod, Int, Integer, show, + return, asTypeOf, (.), Show, (+), succ, Maybe (..), (*), mod, map, flip, otherwise, (-), div, maybe, Char) +import qualified Prelude + +newtype NonEmpty' a = NonEmpty' (NE.NonEmpty a) + deriving (Show, Eq) +instance Arbitrary a => Arbitrary (NonEmpty' a) where + arbitrary = NonEmpty' <$> ((NE.:|) <$> arbitrary <*> arbitrary) + +-- | Arbitrary newtype for key-value pairs without any duplicate keys +-- and is not empty +newtype DuplPairs k v = DuplPairs { unDupl :: [(k,v)] } + deriving (Eq, Show) + +removeDuplicateKeys :: Ord k => [(k,v)] -> [(k,v)] +removeDuplicateKeys m = go Set.empty m + where go _ [] = [] + go used ((k,v):xs) + | k `member` used = go used xs + | otherwise = (k,v) : go (insertSet k used) xs + +instance (Arbitrary k, Arbitrary v, Ord k, Eq v) => Arbitrary (DuplPairs k v) where + arbitrary = DuplPairs . removeDuplicateKeys <$> arbitrary `suchThat` (/= []) + shrink (DuplPairs xs) = + map (DuplPairs . removeDuplicateKeys) $ filter (/= []) $ shrink xs + +-- | Arbitrary newtype for small lists whose length is <= 10 +-- +-- Used for testing 'unionsWith' +newtype SmallList a = SmallList { getSmallList :: [a] } + deriving (Eq, Show, Ord) + +instance (Arbitrary a) => Arbitrary (SmallList a) where + arbitrary = SmallList <$> arbitrary `suchThat` ((<= 10) . olength) + shrink (SmallList xs) = + map SmallList $ filter ((<= 10) . olength) $ shrink xs + +-- | Choose a random key from a key-value pair list +indexIn :: (Show k, Testable prop) => [(k,v)] -> (k -> prop) -> Property +indexIn = forAll . elements . map Prelude.fst + +-- | Type restricted 'fromList' +fromListAs :: IsSequence a => [Element a] -> a -> a +fromListAs xs _ = fromList xs + +-- | Type restricted 'mapFromListAs' +mapFromListAs :: IsMap a => [(ContainerKey a, MapValue a)] -> a -> a +mapFromListAs xs _ = mapFromList xs + +instance IsString (V.Vector Char) where fromString = V.fromList +instance IsString (U.Vector Char) where fromString = U.fromList +instance IsString (VS.Vector Char) where fromString = VS.fromList +#if MIN_VERSION_vector(0,13,2) +instance IsString (VSC.Vector Char) where fromString = VSC.fromList +#endif + +main :: IO () +main = hspec $ do + describe "onull" $ do + it "works on empty lists" $ onull [] @?= True + it "works on non-empty lists" $ onull [()] @?= False + it "works on empty texts" $ onull ("" :: Text) @?= True + it "works on non-empty texts" $ onull ("foo" :: Text) @?= False + + describe "osum" $ do + prop "works on lists" $ \(Small x) (Small y) -> + y >= x ==> osum [x..y] @?= ((x + y) * (y - x + 1) `div` (2 :: Int)) + + describe "oproduct" $ do + prop "works on lists" $ \(Positive x) (Positive y) -> + let fact n = oproduct [1..n] + in (y :: Integer) > (x :: Integer) ==> + oproduct [x..y] @?= fact y `div` fact (x - 1) + + describe "olength" $ do + prop "works on lists" $ \(NonNegative i) -> + olength (replicate i () :: [()]) @?= i + prop "works on texts" $ \(NonNegative i) -> + olength (replicate i 'a' :: Text) @?= i + prop "works on lazy bytestrings" $ \(NonNegative (Small i)) -> + olength64 (replicate i 6 :: L.ByteString) @?= i + + describe "omap" $ do + prop "works on lists" $ \xs -> + omap (+1) xs @?= map (+1) (xs :: [Int]) + prop "works on lazy bytestrings" $ \xs -> + omap (+1) (fromList xs :: L.ByteString) @?= fromList (map (+1) xs) + prop "works on texts" $ \xs -> + omap succ (fromList xs :: Text) @?= fromList (map succ xs) + + describe "oconcatMap" $ do + prop "works on lists" $ \xs -> + oconcatMap (: []) xs @?= (xs :: [Int]) + + describe "ocompareLength" $ do + prop "works on lists" $ \(Positive i) j -> + ocompareLength (replicate i () :: [()]) j @?= compare i j + + describe "groupBy" $ do + let test name dummy = prop name $ \xs (Fn2 g) -> do + let seq' = fromListAs xs dummy + let listDef f = Prelude.fmap fromList . List.groupBy f . otoList + groupBy (==) seq' @?= listDef (==) seq' + groupBy (/=) seq' @?= listDef (/=) seq' + groupBy (<) seq' @?= listDef (<) seq' + groupBy (>) seq' @?= listDef (>) seq' + groupBy g seq' @?= listDef g seq' + test "works on lists" ([] :: [Char]) + test "works on texts" ("" :: Text) + test "works on strict bytestrings" S.empty + test "works on lazy bytestrings" L.empty + test "works on Vector" (V.singleton ('a' :: Char)) + test "works on SVector" (VS.singleton ('a' :: Char)) +#if MIN_VERSION_vector(0,13,2) + test "works on StrictVector" (VSC.singleton ('a' :: Char)) +#endif + test "works on UVector" (U.singleton ('a' :: Char)) + test "works on Seq" (Seq.fromList ['a' :: Char]) + + describe "groupAll" $ do + it "works on lists" $ groupAll ("abcabcabc" :: String) @?= ["aaa", "bbb", "ccc"] + it "works on texts" $ groupAll ("abcabcabc" :: Text) @?= ["aaa", "bbb", "ccc"] + + describe "unsnoc" $ do + let test name dummy = prop name $ \(QCM.NonEmpty xs) -> + let seq' = fromListAs xs dummy + in case unsnoc seq' of + Just (y, z) -> do + y SG.<> singleton z @?= seq' + snoc y z @?= seq' + otoList (snoc y z) @?= xs + Nothing -> expectationFailure "unsnoc returned Nothing" + test "works on lists" ([] :: [Int]) + test "works on texts" ("" :: Text) + test "works on lazy bytestrings" L.empty + + describe "index" $ do + let test name dummy = prop name $ + \i' (QCM.NonEmpty xs) -> + let seq' = fromListAs xs dummy + mx = index xs (fromIntegral i) + i = fromIntegral (i' :: Int) + in do + mx @?= index seq' i + case mx of + Nothing -> return () + Just x -> indexEx seq' i @?= x + test "works on lists" ([] :: [Int]) + test "works on strict texts" ("" :: Text) + test "works on lazy texts" ("" :: TL.Text) + test "works on strict bytestrings" S.empty + test "works on lazy bytestrings" L.empty + test "works on Vector" (V.singleton (1 :: Int)) + test "works on SVector" (VS.singleton (1 :: Int)) +#if MIN_VERSION_vector(0,13,2) + test "works on StrictVector" (VSC.singleton (1 :: Int)) +#endif + test "works on UVector" (U.singleton (1 :: Int)) + test "works on Seq" (Seq.fromList [1 :: Int]) + + describe "groupAllOn" $ do + it "works on lists" $ + groupAllOn (`mod` 3) ([1..9] :: [Int]) @?= [[1, 4, 7], [2, 5, 8], [3, 6, 9]] + + describe "breakWord" $ do + let test x y z = it (show (x, y, z)) $ breakWord (x :: Text) @?= (y, z) + test "hello world" "hello" "world" + test "hello world" "hello" "world" + test "hello\r\nworld" "hello" "world" + test "hello there world" "hello" "there world" + test "" "" "" + test "hello \n\r\t" "hello" "" + + describe "breakLine" $ do + let test x y z = it (show (x, y, z)) $ breakLine (x :: Text) @?= (y, z) + test "hello world" "hello world" "" + test "hello\r\n world" "hello" " world" + test "hello\n world" "hello" " world" + test "hello\r world" "hello\r world" "" + test "hello\r\nworld" "hello" "world" + test "hello\r\nthere\nworld" "hello" "there\nworld" + test "hello\n\r\nworld" "hello" "\r\nworld" + test "" "" "" + + describe "omapM_" $ do + let test typ dummy = prop typ $ \input -> + input @?= execWriter (omapM_ (tell . return) (fromListAs input dummy)) + test "works on strict bytestrings" S.empty + test "works on lazy bytestrings" L.empty + test "works on strict texts" T.empty + test "works on lazy texts" TL.empty + + describe "inits" $ do + let test typ emptyTyp = describe typ $ do + it "empty" $ inits emptyTyp @?= [""] + it "one element" $ inits ("a" <> emptyTyp) @?= ["", "a"] + it "two elements" $ inits ("ab" <> emptyTyp) @?= ["", "a", "ab"] + test "String" (mempty :: String) + test "StrictBytestring" S.empty + test "LazyBytestring" L.empty + test "StrictText" T.empty + test "LazyText" TL.empty + test "Seq" Seq.empty + test "Vector" (mempty :: V.Vector Char) + test "Unboxed Vector" (mempty :: U.Vector Char) + test "Storable Vector" (mempty :: VS.Vector Char) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (mempty :: VSC.Vector Char) +#endif + + describe "tails" $ do + let test typ emptyTyp = describe typ $ do + it "empty" $ tails emptyTyp @?= [""] + it "one element" $ tails ("a" <> emptyTyp) @?= ["a", ""] + it "two elements" $ tails ("ab" <> emptyTyp) @?= ["ab", "b", ""] + test "String" (mempty :: String) + test "StrictBytestring" S.empty + test "LazyBytestring" L.empty + test "StrictText" T.empty + test "LazyText" TL.empty + test "Seq" Seq.empty + test "Vector" (mempty :: V.Vector Char) + test "Unboxed Vector" (mempty :: U.Vector Char) + test "Storable Vector" (mempty :: VS.Vector Char) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (mempty :: VSC.Vector Char) +#endif + + describe "initTails" $ do + let test typ emptyTyp = describe typ $ do + it "empty" $ initTails emptyTyp @?= [("","")] + it "one element" $ initTails ("a" <> emptyTyp) @?= [("","a"), ("a","")] + it "two elements" $ initTails ("ab" <> emptyTyp) @?= [("","ab"), ("a","b"), ("ab","")] + test "String" (mempty :: String) + test "StrictBytestring" S.empty + test "LazyBytestring" L.empty + test "StrictText" T.empty + test "LazyText" TL.empty + test "Seq" Seq.empty + test "Vector" (mempty :: V.Vector Char) + test "Unboxed Vector" (mempty :: U.Vector Char) + test "Storable Vector" (mempty :: VS.Vector Char) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (mempty :: VSC.Vector Char) +#endif + + describe "NonNull" $ do + describe "fromNonEmpty" $ do + prop "toMinList" $ \(NonEmpty' ne) -> + (NE.toList ne :: [Int]) @?= NN.toNullable (NN.toMinList ne) + describe "toNonEmpty" $ do + it "converts nonnull to nonempty" $ do + NN.toNonEmpty (NN.impureNonNull [1,2,3]) @?= NE.fromList [1,2,3] + + describe "mapNonNull" $ do + prop "mapNonNull id == id" $ \x xs -> + let nonNull = NN.ncons x (xs :: [Int]) + in NN.mapNonNull Prelude.id nonNull @?= nonNull + prop "mapNonNull (f . g) == mapNonNull f . mapNonNull g" $ + \(Fn (f :: Integer -> String)) (Fn (g :: Int -> Integer)) x xs -> + let nns = NN.ncons x (xs :: [Int]) + in NN.mapNonNull (f . g) nns @?= NN.mapNonNull f (NN.mapNonNull g nns) + + let -- | Type restricted 'NN.ncons' + nconsAs :: IsSequence seq => Element seq -> [Element seq] -> seq -> NN.NonNull seq + nconsAs x xs _ = NN.ncons x (fromList xs) + + test :: (IsSequence typ, Ord (Element typ), Arbitrary (Element typ), Show (Element typ), Show typ, Eq typ, Eq (Element typ)) + => String -> typ -> Spec + test typ du = describe typ $ do + prop "head" $ \x xs -> + NN.head (nconsAs x xs du) @?= x + prop "tail" $ \x xs -> + NN.tail (nconsAs x xs du) @?= fromList xs + prop "last" $ \x xs -> + NN.last (reverse $ nconsAs x xs du) @?= x + prop "init" $ \x xs -> + NN.init (reverse $ nconsAs x xs du) @?= reverse (fromList xs) + prop "maximum" $ \x xs -> + NN.maximum (nconsAs x xs du) @?= Prelude.maximum (x:xs) + prop "maximumBy" $ \x xs -> + NN.maximumBy compare (nconsAs x xs du) @?= Prelude.maximum (x:xs) + prop "minimum" $ \x xs -> + NN.minimum (nconsAs x xs du) @?= Prelude.minimum (x:xs) + prop "minimumBy" $ \x xs -> + NN.minimumBy compare (nconsAs x xs du) @?= Prelude.minimum (x:xs) + prop "ofoldMap1" $ \x xs -> + SG.getMax (NN.ofoldMap1 SG.Max $ nconsAs x xs du) @?= Prelude.maximum (x:xs) + prop "ofoldr1" $ \x xs -> + NN.ofoldr1 Prelude.min (nconsAs x xs du) @?= Prelude.minimum (x:xs) + prop "ofoldl1'" $ \x xs -> + NN.ofoldl1' Prelude.min (nconsAs x xs du) @?= Prelude.minimum (x:xs) + + test "Strict ByteString" S.empty + test "Lazy ByteString" L.empty + test "Strict Text" T.empty + test "Lazy Text" TL.empty + test "Vector" (V.empty :: V.Vector Int) + test "Unboxed Vector" (U.empty :: U.Vector Int) + test "Storable Vector" (VS.empty :: VS.Vector Int) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (VSC.empty :: VSC.Vector Int) +#endif + test "List" ([5 :: Int]) + + describe "Containers" $ do + let test typ dummy xlookup xinsert xdelete = describe typ $ do + prop "difference" $ \(DuplPairs xs) (DuplPairs ys) -> + let m1 = mapFromList xs `difference` mapFromList ys + m2 = mapFromListAs (xs `difference` ys) dummy + in m1 @?= m2 + + prop "lookup" $ \(DuplPairs xs) -> indexIn xs $ \k -> + let m = mapFromListAs xs dummy + v1 = lookup k m + in do + v1 @?= lookup k xs + v1 @?= xlookup k m + + prop "insert" $ \(DuplPairs xs) v -> indexIn xs $ \k -> + let m = mapFromListAs xs dummy + m1 = insertMap k v m + in do + m1 @?= mapFromList (insertMap k v xs) + m1 @?= xinsert k v m + + prop "delete" $ \(DuplPairs xs) -> indexIn xs $ \k -> + let m = mapFromListAs xs dummy + m1 = deleteMap k m + in do + m1 @?= mapFromList (deleteMap k xs) + m1 @?= xdelete k m + + prop "singletonMap" $ \k v -> + singletonMap k v @?= (mapFromListAs [(k, v)] dummy) + + prop "findWithDefault" $ \(DuplPairs xs) k v -> + findWithDefault v k (mapFromListAs xs dummy) + @?= findWithDefault v k xs + + prop "insertWith" $ \(DuplPairs xs) k v -> + insertWith (+) k v (mapFromListAs xs dummy) + @?= mapFromList (insertWith (+) k v xs) + + prop "insertWithKey" $ \(DuplPairs xs) k v -> + let m = mapFromListAs xs dummy + f x y z = x + y + z + in insertWithKey f k v m + @?= mapFromList (insertWithKey f k v xs) + + prop "insertLookupWithKey" $ \(DuplPairs xs) k v -> + let m = mapFromListAs xs dummy + f x y z = x + y + z + in insertLookupWithKey f k v m @?= + second mapFromList (insertLookupWithKey f k v xs) + + prop "adjustMap" $ \(DuplPairs xs) k -> + adjustMap succ k (mapFromListAs xs dummy) + @?= mapFromList (adjustMap succ k xs) + + prop "adjustWithKey" $ \(DuplPairs xs) k -> + adjustWithKey (+) k (mapFromListAs xs dummy) + @?= mapFromList (adjustWithKey (+) k xs) + + prop "updateMap" $ \(DuplPairs xs) k -> + let f i = if i < 0 then Nothing else Just $ i * 2 + in updateMap f k (mapFromListAs xs dummy) + @?= mapFromList (updateMap f k xs) + + prop "updateWithKey" $ \(DuplPairs xs) k' -> + let f k i = if i < 0 then Nothing else Just $ i * k + in updateWithKey f k' (mapFromListAs xs dummy) + @?= mapFromList (updateWithKey f k' xs) + + prop "updateLookupWithKey" $ \(DuplPairs xs) k' -> + let f k i = if i < 0 then Nothing else Just $ i * k + in updateLookupWithKey f k' (mapFromListAs xs dummy) + @?= second mapFromList (updateLookupWithKey f k' xs) + + prop "alter" $ \(DuplPairs xs) k -> + let m = mapFromListAs xs dummy + f Nothing = Just (-1) + f (Just i) = if i < 0 then Nothing else Just (i * 2) + in lookup k (alterMap f k m) @?= f (lookup k m) + + prop "unionWith" $ \(DuplPairs xs) (DuplPairs ys) -> + let m1 = unionWith (+) + (mapFromListAs xs dummy) + (mapFromListAs ys dummy) + m2 = mapFromList (unionWith (+) xs ys) + in m1 @?= m2 + + prop "unionWithKey" $ \(DuplPairs xs) (DuplPairs ys) -> + let f k x y = k + x + y + m1 = unionWithKey f + (mapFromListAs xs dummy) + (mapFromListAs ys dummy) + m2 = mapFromList (unionWithKey f xs ys) + in m1 @?= m2 + + prop "unionsWith" $ \(SmallList xss) -> + let duplXss = map unDupl xss + ms = map mapFromList duplXss `asTypeOf` [dummy] + in unionsWith (+) ms + @?= mapFromList (unionsWith (+) duplXss) + + prop "mapWithKey" $ \(DuplPairs xs) -> + let m1 = mapWithKey (+) (mapFromList xs) `asTypeOf` dummy + m2 = mapFromList $ mapWithKey (+) xs + in m1 @?= m2 + + prop "omapKeysWith" $ \(DuplPairs xs) -> + let f = flip mod 5 + m1 = omapKeysWith (+) f (mapFromList xs) `asTypeOf` dummy + m2 = mapFromList $ omapKeysWith (+) f xs + in m1 @?= m2 + + test "Data.Map" (Map.empty :: Map.Map Int Int) + Map.lookup Map.insert Map.delete + test "Data.IntMap" (IntMap.empty :: IntMap.IntMap Int) + IntMap.lookup IntMap.insert IntMap.delete + test "Data.HashMap" (HashMap.empty :: HashMap.HashMap Int Int) + HashMap.lookup HashMap.insert HashMap.delete + + describe "Foldl Integration" $ do + prop "vector" $ \xs -> do +#if MIN_VERSION_foldl(1,3,0) + let x1 = Foldl.fold Foldl.vector (xs :: [Int]) + x2 = Foldl.purely ofoldlUnwrap Foldl.vector xs +#else + x1 <- Foldl.foldM Foldl.vector (xs :: [Int]) + x2 <- Foldl.impurely ofoldMUnwrap Foldl.vector xs +#endif + x2 @?= (x1 :: V.Vector Int) + prop "length" $ \xs -> do + let x1 = Foldl.fold Foldl.length (xs :: [Int]) + x2 = Foldl.purely ofoldlUnwrap Foldl.length xs + x2 @?= x1 + + describe "Replacing" $ do + let test typ dummy = describe typ $ do + prop "replaceElem old new === omap (\\x -> if x == old then new else x)" $ + -- replace random element or any random value with random new value + \x list new -> forAll (elements (x:list)) $ \old -> + let seq' = fromListAs list dummy + in replaceElem old new seq' @?= omap (\x' -> if x' == old then new else x') seq' +#if MIN_VERSION_QuickCheck(2,8,0) + prop "replaceSeq old new === ointercalate new . splitSeq old" $ + -- replace random subsequence with random new sequence + \list new -> forAll (sublistOf list) $ \old -> + let [seq', old', new'] = map (`fromListAs` dummy) [list, old, new] + in replaceSeq old' new' seq' @?= ointercalate new' (splitSeq old' seq') + prop "replaceSeq old old === id" $ \list -> forAll (sublistOf list) $ \old -> + let [seq', old'] = map (`fromListAs` dummy) [list, old] + in replaceSeq old' old' seq' @?= seq' +#endif + test "List" ([] :: [Int]) + test "Vector" (V.empty :: V.Vector Int) + test "Storable Vector" (VS.empty :: VS.Vector Int) + test "Unboxed Vector" (U.empty :: U.Vector Int) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (VSC.empty :: VSC.Vector Int) +#endif + test "Strict ByteString" S.empty + test "Lazy ByteString" L.empty + test "Strict Text" T.empty + test "Lazy Text" TL.empty + + describe "Sorting" $ do + let test typ dummy = describe typ $ do + prop "sortBy" $ \input -> do + let f x y = compare y x + fromList (sortBy f input) @?= sortBy f (fromListAs input dummy) + prop "sort" $ \input -> + fromList (sort input) @?= sort (fromListAs input dummy) + test "List" ([] :: [Int]) + test "Vector" (V.empty :: V.Vector Int) + test "Storable Vector" (VS.empty :: VS.Vector Int) + test "Unboxed Vector" (U.empty :: U.Vector Int) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (VSC.empty :: VSC.Vector Int) +#endif + test "Strict ByteString" S.empty + test "Lazy ByteString" L.empty + test "Strict Text" T.empty + test "Lazy Text" TL.empty + + describe "Intercalate" $ do + let test typ dummy = describe typ $ do + prop "intercalate === defaultIntercalate" $ \list lists -> + let seq' = fromListAs list dummy + seqs = map (`fromListAs` dummy) lists + in ointercalate seq' seqs @?= fromList (List.intercalate list lists) + test "List" ([] :: [Int]) + test "Vector" (V.empty :: V.Vector Int) + test "Storable Vector" (VS.empty :: VS.Vector Int) + test "Unboxed Vector" (U.empty :: U.Vector Int) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (VSC.empty :: VSC.Vector Int) +#endif + test "Strict ByteString" S.empty + test "Lazy ByteString" L.empty + test "Strict Text" T.empty + test "Lazy Text" TL.empty + + describe "Splitting" $ do + let test typ dummy = describe typ $ do + let fromList' = (`fromListAs` dummy) + let fromSepList sep = fromList' . map (fromMaybe sep) + prop "intercalate sep . splitSeq sep === id" $ + \(fromList' -> sep) -> + \(mconcat . map (maybe sep fromList') -> xs) -> + ointercalate sep (splitSeq sep xs) @?= xs + prop "splitSeq mempty xs === mempty : map singleton (otoList xs)" $ + \input -> + splitSeq mempty (fromList' input) @?= mempty : map singleton input + prop "splitSeq _ mempty == [mempty]" $ + \(fromList' -> sep) -> + splitSeq sep mempty @?= [mempty] + prop "intercalate (singleton sep) . splitElem sep === id" $ + \sep -> \(fromSepList sep -> xs) -> + ointercalate (singleton sep) (splitElem sep xs) @?= xs + prop "length . splitElem sep === succ . length . filter (== sep)" $ + \sep -> \(fromSepList sep -> xs) -> + olength (splitElem sep xs) @?= olength (filter (== sep) xs) + 1 + prop "splitElem sep (replicate n sep) == replicate (n+1) mempty" $ + \(NonNegative n) sep -> + splitElem sep (fromList' (replicate n sep)) @?= replicate (n + 1) mempty + prop "splitElem sep === splitWhen (== sep)" $ + \sep -> \(fromSepList sep -> xs) -> + splitElem sep xs @?= splitWhen (== sep) xs + prop "splitElem sep === splitSeq (singleton sep)" $ + \sep -> \(fromSepList sep -> xs) -> + splitElem sep xs @?= splitSeq (singleton sep) xs + test "List" ([] :: [Int]) + test "Vector" (V.empty :: V.Vector Int) + test "Storable Vector" (VS.empty :: VS.Vector Int) + test "Unboxed Vector" (U.empty :: U.Vector Int) +#if MIN_VERSION_vector(0,13,2) + test "Strict Vector" (VSC.empty :: VSC.Vector Int) +#endif + test "Strict ByteString" S.empty + test "Lazy ByteString" L.empty + test "Strict Text" T.empty + test "Lazy Text" TL.empty + + describe "Other Issues" $ do + it "#26 headEx on a list works" $ + headEx (1 : filter Prelude.odd [2,4..]) @?= (1 :: Int) + + it "#31 find doesn't infinitely loop on NonEmpty" $ + find (== "a") ("a" NE.:| ["d","fgf"]) @?= Just ("a" :: String) + + it "#83 head on Seq works correctly" $ do + headEx (Seq.fromList [1 :: Int,2,3]) @?= (1 :: Int) + headMay (Seq.fromList [] :: Seq.Seq Int) @?= Nothing diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} - -module Spec where - -import Data.MonoTraversable -import Data.Containers -import Data.Sequences -import qualified Data.Sequence as Seq -import qualified Data.NonNull as NN -import Data.Monoid (mempty, mconcat) -import Data.Maybe (fromMaybe) -import qualified Data.List as List - -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.HUnit ((@?=)) -import Test.QuickCheck hiding (NonEmptyList(..)) -import qualified Test.QuickCheck.Modifiers as QCM - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Storable as VS -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as SG -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as Set -import qualified Control.Foldl as Foldl - -import Control.Arrow (second) -import Control.Applicative -import Control.Monad.Trans.Writer - -import Prelude (Bool (..), ($), IO, Eq (..), fromIntegral, Ord (..), String, mod, Int, Integer, show, - return, asTypeOf, (.), Show, (+), succ, Maybe (..), (*), mod, map, flip, otherwise, (-), div, maybe) -import qualified Prelude - -newtype NonEmpty' a = NonEmpty' (NE.NonEmpty a) - deriving (Show, Eq) -instance Arbitrary a => Arbitrary (NonEmpty' a) where - arbitrary = NonEmpty' <$> ((NE.:|) <$> arbitrary <*> arbitrary) - --- | Arbitrary newtype for key-value pairs without any duplicate keys --- and is not empty -newtype DuplPairs k v = DuplPairs { unDupl :: [(k,v)] } - deriving (Eq, Show) - -removeDuplicateKeys :: Ord k => [(k,v)] -> [(k,v)] -removeDuplicateKeys m = go Set.empty m - where go _ [] = [] - go used ((k,v):xs) - | k `member` used = go used xs - | otherwise = (k,v) : go (insertSet k used) xs - -instance (Arbitrary k, Arbitrary v, Ord k, Eq v) => Arbitrary (DuplPairs k v) where - arbitrary = DuplPairs . removeDuplicateKeys <$> arbitrary `suchThat` (/= []) - shrink (DuplPairs xs) = - map (DuplPairs . removeDuplicateKeys) $ filter (/= []) $ shrink xs - --- | Arbitrary newtype for small lists whose length is <= 10 --- --- Used for testing 'unionsWith' -newtype SmallList a = SmallList { getSmallList :: [a] } - deriving (Eq, Show, Ord) - -instance (Arbitrary a) => Arbitrary (SmallList a) where - arbitrary = SmallList <$> arbitrary `suchThat` ((<= 10) . olength) - shrink (SmallList xs) = - map SmallList $ filter ((<= 10) . olength) $ shrink xs - --- | Choose a random key from a key-value pair list -indexIn :: (Show k, Testable prop) => [(k,v)] -> (k -> prop) -> Property -indexIn = forAll . elements . map Prelude.fst - --- | Type restricted 'fromList' -fromListAs :: IsSequence a => [Element a] -> a -> a -fromListAs xs _ = fromList xs - --- | Type restricted 'mapFromListAs' -mapFromListAs :: IsMap a => [(ContainerKey a, MapValue a)] -> a -> a -mapFromListAs xs _ = mapFromList xs - -main :: IO () -main = hspec $ do - describe "onull" $ do - it "works on empty lists" $ onull [] @?= True - it "works on non-empty lists" $ onull [()] @?= False - it "works on empty texts" $ onull ("" :: Text) @?= True - it "works on non-empty texts" $ onull ("foo" :: Text) @?= False - - describe "osum" $ do - prop "works on lists" $ \(Small x) (Small y) -> - y >= x ==> osum [x..y] @?= ((x + y) * (y - x + 1) `div` (2 :: Int)) - - describe "oproduct" $ do - prop "works on lists" $ \(Positive x) (Positive y) -> - let fact n = oproduct [1..n] - in (y :: Integer) > (x :: Integer) ==> - oproduct [x..y] @?= fact y `div` fact (x - 1) - - describe "olength" $ do - prop "works on lists" $ \(NonNegative i) -> - olength (replicate i () :: [()]) @?= i - prop "works on texts" $ \(NonNegative i) -> - olength (replicate i 'a' :: Text) @?= i - prop "works on lazy bytestrings" $ \(NonNegative (Small i)) -> - olength64 (replicate i 6 :: L.ByteString) @?= i - - describe "omap" $ do - prop "works on lists" $ \xs -> - omap (+1) xs @?= map (+1) (xs :: [Int]) - prop "works on lazy bytestrings" $ \xs -> - omap (+1) (fromList xs :: L.ByteString) @?= fromList (map (+1) xs) - prop "works on texts" $ \xs -> - omap succ (fromList xs :: Text) @?= fromList (map succ xs) - - describe "oconcatMap" $ do - prop "works on lists" $ \xs -> - oconcatMap (: []) xs @?= (xs :: [Int]) - - describe "ocompareLength" $ do - prop "works on lists" $ \(Positive i) j -> - ocompareLength (replicate i () :: [()]) j @?= compare i j - - describe "groupAll" $ do - it "works on lists" $ groupAll ("abcabcabc" :: String) @?= ["aaa", "bbb", "ccc"] - it "works on texts" $ groupAll ("abcabcabc" :: Text) @?= ["aaa", "bbb", "ccc"] - - describe "unsnoc" $ do - let test name dummy = prop name $ \(QCM.NonEmpty xs) -> - let seq' = fromListAs xs dummy - in case unsnoc seq' of - Just (y, z) -> do - y SG.<> singleton z @?= seq' - snoc y z @?= seq' - otoList (snoc y z) @?= xs - Nothing -> expectationFailure "unsnoc returned Nothing" - test "works on lists" ([] :: [Int]) - test "works on texts" ("" :: Text) - test "works on lazy bytestrings" L.empty - - describe "index" $ do - let test name dummy = prop name $ - \(NonNegative i') (QCM.NonEmpty xs) -> - let seq' = fromListAs xs dummy - mx = index xs (fromIntegral i) - i = fromIntegral (i' :: Int) - in do - mx @?= index seq' i - case mx of - Nothing -> return () - Just x -> indexEx seq' i @?= x - test "works on lists" ([] :: [Int]) - test "works on strict texts" ("" :: Text) - test "works on lazy texts" ("" :: TL.Text) - test "works on strict bytestrings" S.empty - test "works on lazy bytestrings" L.empty - test "works on Vector" (V.singleton (1 :: Int)) - test "works on SVector" (VS.singleton (1 :: Int)) - test "works on UVector" (U.singleton (1 :: Int)) - test "works on Seq" (Seq.fromList [1 :: Int]) - - describe "groupAllOn" $ do - it "works on lists" $ - groupAllOn (`mod` 3) ([1..9] :: [Int]) @?= [[1, 4, 7], [2, 5, 8], [3, 6, 9]] - - describe "breakWord" $ do - let test x y z = it (show (x, y, z)) $ breakWord (x :: Text) @?= (y, z) - test "hello world" "hello" "world" - test "hello world" "hello" "world" - test "hello\r\nworld" "hello" "world" - test "hello there world" "hello" "there world" - test "" "" "" - test "hello \n\r\t" "hello" "" - - describe "breakLine" $ do - let test x y z = it (show (x, y, z)) $ breakLine (x :: Text) @?= (y, z) - test "hello world" "hello world" "" - test "hello\r\n world" "hello" " world" - test "hello\n world" "hello" " world" - test "hello\r world" "hello\r world" "" - test "hello\r\nworld" "hello" "world" - test "hello\r\nthere\nworld" "hello" "there\nworld" - test "hello\n\r\nworld" "hello" "\r\nworld" - test "" "" "" - - describe "omapM_" $ do - let test typ dummy = prop typ $ \input -> - input @?= execWriter (omapM_ (tell . return) (fromListAs input dummy)) - test "works on strict bytestrings" S.empty - test "works on lazy bytestrings" L.empty - test "works on strict texts" T.empty - test "works on lazy texts" TL.empty - - describe "NonNull" $ do - describe "fromNonEmpty" $ do - prop "toMinList" $ \(NonEmpty' ne) -> - (NE.toList ne :: [Int]) @?= NN.toNullable (NN.toMinList ne) - - let -- | Type restricted 'NN.ncons' - nconsAs :: IsSequence seq => Element seq -> [Element seq] -> seq -> NN.NonNull seq - nconsAs x xs _ = NN.ncons x (fromList xs) - - test :: (IsSequence typ, Ord (Element typ), Arbitrary (Element typ), Show (Element typ), Show typ, Eq typ, Eq (Element typ)) - => String -> typ -> Spec - test typ du = describe typ $ do - prop "head" $ \x xs -> - NN.head (nconsAs x xs du) @?= x - prop "tail" $ \x xs -> - NN.tail (nconsAs x xs du) @?= fromList xs - prop "last" $ \x xs -> - NN.last (reverse $ nconsAs x xs du) @?= x - prop "init" $ \x xs -> - NN.init (reverse $ nconsAs x xs du) @?= reverse (fromList xs) - prop "maximum" $ \x xs -> - NN.maximum (nconsAs x xs du) @?= Prelude.maximum (x:xs) - prop "maximumBy" $ \x xs -> - NN.maximumBy compare (nconsAs x xs du) @?= Prelude.maximum (x:xs) - prop "minimum" $ \x xs -> - NN.minimum (nconsAs x xs du) @?= Prelude.minimum (x:xs) - prop "minimumBy" $ \x xs -> - NN.minimumBy compare (nconsAs x xs du) @?= Prelude.minimum (x:xs) - prop "ofoldMap1" $ \x xs -> - SG.getMax (NN.ofoldMap1 SG.Max $ nconsAs x xs du) @?= Prelude.maximum (x:xs) - prop "ofoldr1" $ \x xs -> - NN.ofoldr1 Prelude.min (nconsAs x xs du) @?= Prelude.minimum (x:xs) - prop "ofoldl1'" $ \x xs -> - NN.ofoldl1' Prelude.min (nconsAs x xs du) @?= Prelude.minimum (x:xs) - - test "Strict ByteString" S.empty - test "Lazy ByteString" L.empty - test "Strict Text" T.empty - test "Lazy Text" TL.empty - test "Vector" (V.empty :: V.Vector Int) - test "Unboxed Vector" (U.empty :: U.Vector Int) - test "Storable Vector" (VS.empty :: VS.Vector Int) - test "List" ([5 :: Int]) - - describe "Containers" $ do - let test typ dummy xlookup xinsert xdelete = describe typ $ do - prop "difference" $ \(DuplPairs xs) (DuplPairs ys) -> - let m1 = mapFromList xs `difference` mapFromList ys - m2 = mapFromListAs (xs `difference` ys) dummy - in m1 @?= m2 - - prop "lookup" $ \(DuplPairs xs) -> indexIn xs $ \k -> - let m = mapFromListAs xs dummy - v1 = lookup k m - in do - v1 @?= lookup k xs - v1 @?= xlookup k m - - prop "insert" $ \(DuplPairs xs) v -> indexIn xs $ \k -> - let m = mapFromListAs xs dummy - m1 = insertMap k v m - in do - m1 @?= mapFromList (insertMap k v xs) - m1 @?= xinsert k v m - - prop "delete" $ \(DuplPairs xs) -> indexIn xs $ \k -> - let m = mapFromListAs xs dummy - m1 = deleteMap k m - in do - m1 @?= mapFromList (deleteMap k xs) - m1 @?= xdelete k m - - prop "singletonMap" $ \k v -> - singletonMap k v @?= (mapFromListAs [(k, v)] dummy) - - prop "findWithDefault" $ \(DuplPairs xs) k v -> - findWithDefault v k (mapFromListAs xs dummy) - @?= findWithDefault v k xs - - prop "insertWith" $ \(DuplPairs xs) k v -> - insertWith (+) k v (mapFromListAs xs dummy) - @?= mapFromList (insertWith (+) k v xs) - - prop "insertWithKey" $ \(DuplPairs xs) k v -> - let m = mapFromListAs xs dummy - f x y z = x + y + z - in insertWithKey f k v m - @?= mapFromList (insertWithKey f k v xs) - - prop "insertLookupWithKey" $ \(DuplPairs xs) k v -> - let m = mapFromListAs xs dummy - f x y z = x + y + z - in insertLookupWithKey f k v m @?= - second mapFromList (insertLookupWithKey f k v xs) - - prop "adjustMap" $ \(DuplPairs xs) k -> - adjustMap succ k (mapFromListAs xs dummy) - @?= mapFromList (adjustMap succ k xs) - - prop "adjustWithKey" $ \(DuplPairs xs) k -> - adjustWithKey (+) k (mapFromListAs xs dummy) - @?= mapFromList (adjustWithKey (+) k xs) - - prop "updateMap" $ \(DuplPairs xs) k -> - let f i = if i < 0 then Nothing else Just $ i * 2 - in updateMap f k (mapFromListAs xs dummy) - @?= mapFromList (updateMap f k xs) - - prop "updateWithKey" $ \(DuplPairs xs) k' -> - let f k i = if i < 0 then Nothing else Just $ i * k - in updateWithKey f k' (mapFromListAs xs dummy) - @?= mapFromList (updateWithKey f k' xs) - - prop "updateLookupWithKey" $ \(DuplPairs xs) k' -> - let f k i = if i < 0 then Nothing else Just $ i * k - in updateLookupWithKey f k' (mapFromListAs xs dummy) - @?= second mapFromList (updateLookupWithKey f k' xs) - - prop "alter" $ \(DuplPairs xs) k -> - let m = mapFromListAs xs dummy - f Nothing = Just (-1) - f (Just i) = if i < 0 then Nothing else Just (i * 2) - in lookup k (alterMap f k m) @?= f (lookup k m) - - prop "unionWith" $ \(DuplPairs xs) (DuplPairs ys) -> - let m1 = unionWith (+) - (mapFromListAs xs dummy) - (mapFromListAs ys dummy) - m2 = mapFromList (unionWith (+) xs ys) - in m1 @?= m2 - - prop "unionWithKey" $ \(DuplPairs xs) (DuplPairs ys) -> - let f k x y = k + x + y - m1 = unionWithKey f - (mapFromListAs xs dummy) - (mapFromListAs ys dummy) - m2 = mapFromList (unionWithKey f xs ys) - in m1 @?= m2 - - prop "unionsWith" $ \(SmallList xss) -> - let duplXss = map unDupl xss - ms = map mapFromList duplXss `asTypeOf` [dummy] - in unionsWith (+) ms - @?= mapFromList (unionsWith (+) duplXss) - - prop "mapWithKey" $ \(DuplPairs xs) -> - let m1 = mapWithKey (+) (mapFromList xs) `asTypeOf` dummy - m2 = mapFromList $ mapWithKey (+) xs - in m1 @?= m2 - - prop "omapKeysWith" $ \(DuplPairs xs) -> - let f = flip mod 5 - m1 = omapKeysWith (+) f (mapFromList xs) `asTypeOf` dummy - m2 = mapFromList $ omapKeysWith (+) f xs - in m1 @?= m2 - - test "Data.Map" (Map.empty :: Map.Map Int Int) - Map.lookup Map.insert Map.delete - test "Data.IntMap" (IntMap.empty :: IntMap.IntMap Int) - IntMap.lookup IntMap.insert IntMap.delete - test "Data.HashMap" (HashMap.empty :: HashMap.HashMap Int Int) - HashMap.lookup HashMap.insert HashMap.delete - - describe "Foldl Integration" $ do - prop "vector" $ \xs -> do - x1 <- Foldl.foldM Foldl.vector (xs :: [Int]) - x2 <- Foldl.impurely ofoldMUnwrap Foldl.vector xs - x2 @?= (x1 :: V.Vector Int) - prop "length" $ \xs -> do - let x1 = Foldl.fold Foldl.length (xs :: [Int]) - x2 = Foldl.purely ofoldlUnwrap Foldl.length xs - x2 @?= x1 - - describe "Replacing" $ do - let test typ dummy = describe typ $ do - prop "replaceElem old new === omap (\\x -> if x == old then new else x)" $ - -- replace random element or any random value with random new value - \x list new -> forAll (elements (x:list)) $ \old -> - let seq' = fromListAs list dummy - in replaceElem old new seq' @?= omap (\x -> if x == old then new else x) seq' -#if MIN_VERSION_QuickCheck(2,8,0) - prop "replaceSeq old new === ointercalate new . splitSeq old" $ - -- replace random subsequence with random new sequence - \list new -> forAll (sublistOf list) $ \old -> - let [seq', old', new'] = map (`fromListAs` dummy) [list, old, new] - in replaceSeq old' new' seq' @?= ointercalate new' (splitSeq old' seq') - prop "replaceSeq old old === id" $ \list -> forAll (sublistOf list) $ \old -> - let [seq', old'] = map (`fromListAs` dummy) [list, old] - in replaceSeq old' old' seq' @?= seq' -#endif - test "List" ([] :: [Int]) - test "Vector" (V.empty :: V.Vector Int) - test "Storable Vector" (VS.empty :: VS.Vector Int) - test "Unboxed Vector" (U.empty :: U.Vector Int) - test "Strict ByteString" S.empty - test "Lazy ByteString" L.empty - test "Strict Text" T.empty - test "Lazy Text" TL.empty - - describe "Sorting" $ do - let test typ dummy = describe typ $ do - prop "sortBy" $ \input -> do - let f x y = compare y x - fromList (sortBy f input) @?= sortBy f (fromListAs input dummy) - prop "sort" $ \input -> - fromList (sort input) @?= sort (fromListAs input dummy) - test "List" ([] :: [Int]) - test "Vector" (V.empty :: V.Vector Int) - test "Storable Vector" (VS.empty :: VS.Vector Int) - test "Unboxed Vector" (U.empty :: U.Vector Int) - test "Strict ByteString" S.empty - test "Lazy ByteString" L.empty - test "Strict Text" T.empty - test "Lazy Text" TL.empty - - describe "Intercalate" $ do - let test typ dummy = describe typ $ do - prop "intercalate === defaultIntercalate" $ \list lists -> - let seq' = fromListAs list dummy - seqs = map (`fromListAs` dummy) lists - in ointercalate seq' seqs @?= fromList (List.intercalate list lists) - test "List" ([] :: [Int]) - test "Vector" (V.empty :: V.Vector Int) - test "Storable Vector" (VS.empty :: VS.Vector Int) - test "Unboxed Vector" (U.empty :: U.Vector Int) - test "Strict ByteString" S.empty - test "Lazy ByteString" L.empty - test "Strict Text" T.empty - test "Lazy Text" TL.empty - - describe "Splitting" $ do - let test typ dummy = describe typ $ do - let fromList' = (`fromListAs` dummy) - let fromSepList sep = fromList' . map (fromMaybe sep) - prop "intercalate sep . splitSeq sep === id" $ - \(fromList' -> sep) -> - \(mconcat . map (maybe sep fromList') -> xs) -> - ointercalate sep (splitSeq sep xs) @?= xs - prop "splitSeq mempty xs === mempty : map singleton (otoList xs)" $ - \input -> - splitSeq mempty (fromList' input) @?= mempty : map singleton input - prop "splitSeq _ mempty == [mempty]" $ - \(fromList' -> sep) -> - splitSeq sep mempty @?= [mempty] - prop "intercalate (singleton sep) . splitElem sep === id" $ - \sep -> \(fromSepList sep -> xs) -> - ointercalate (singleton sep) (splitElem sep xs) @?= xs - prop "length . splitElem sep === succ . length . filter (== sep)" $ - \sep -> \(fromSepList sep -> xs) -> - olength (splitElem sep xs) @?= olength (filter (== sep) xs) + 1 - prop "splitElem sep (replicate n sep) == replicate (n+1) mempty" $ - \(NonNegative n) sep -> - splitElem sep (fromList' (replicate n sep)) @?= replicate (n + 1) mempty - prop "splitElem sep === splitWhen (== sep)" $ - \sep -> \(fromSepList sep -> xs) -> - splitElem sep xs @?= splitWhen (== sep) xs - prop "splitElem sep === splitSeq (singleton sep)" $ - \sep -> \(fromSepList sep -> xs) -> - splitElem sep xs @?= splitSeq (singleton sep) xs - test "List" ([] :: [Int]) - test "Vector" (V.empty :: V.Vector Int) - test "Storable Vector" (VS.empty :: VS.Vector Int) - test "Unboxed Vector" (U.empty :: U.Vector Int) - test "Strict ByteString" S.empty - test "Lazy ByteString" L.empty - test "Strict Text" T.empty - test "Lazy Text" TL.empty - - describe "Other Issues" $ do - it "#26 headEx on a list works" $ - headEx (1 : filter Prelude.odd [2,4..]) @?= (1 :: Int) - - it "#31 find doesn't infinitely loop on NonEmpty" $ - find (== "a") ("a" NE.:| ["d","fgf"]) @?= Just ("a" :: String) - - it "#83 head on Seq works correctly" $ do - headEx (Seq.fromList [1 :: Int,2,3]) @?= (1 :: Int) - headMay (Seq.fromList [] :: Seq.Seq Int) @?= Nothing diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,1 +0,0 @@ -import Spec (main)