diff --git a/mono-traversable/ChangeLog.md b/mono-traversable/ChangeLog.md index 6aaa727d..df870562 100644 --- a/mono-traversable/ChangeLog.md +++ b/mono-traversable/ChangeLog.md @@ -1,5 +1,11 @@ # ChangeLog for mono-traversable +## 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 diff --git a/mono-traversable/bench/InitTails.hs b/mono-traversable/bench/InitTails.hs new file mode 100644 index 00000000..1a6a7213 --- /dev/null +++ b/mono-traversable/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/mono-traversable/bench/sorting.hs b/mono-traversable/bench/Sorting.hs similarity index 82% rename from mono-traversable/bench/sorting.hs rename to mono-traversable/bench/Sorting.hs index ac68041c..3a4710fc 100644 --- a/mono-traversable/bench/sorting.hs +++ b/mono-traversable/bench/Sorting.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +module Sorting (sortingBenchmarks) where #if MIN_VERSION_gauge(0,2,0) import Gauge @@ -12,6 +13,13 @@ 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 @@ -19,10 +27,6 @@ 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 diff --git a/mono-traversable/bench/main.hs b/mono-traversable/bench/main.hs new file mode 100644 index 00000000..84dce016 --- /dev/null +++ b/mono-traversable/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/mono-traversable/mono-traversable.cabal b/mono-traversable/mono-traversable.cabal index 3502f2ba..1baf9a93 100644 --- a/mono-traversable/mono-traversable.cabal +++ b/mono-traversable/mono-traversable.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: mono-traversable -version: 1.0.16.0 +version: 1.0.17.0 synopsis: Type classes for mapping, folding, and traversing monomorphic containers description: Please see the README at category: Data @@ -72,18 +72,26 @@ test-suite test , vector default-language: Haskell2010 -benchmark sorting +benchmark all type: exitcode-stdio-1.0 - main-is: sorting.hs + main-is: main.hs other-modules: + InitTails + Sorting Paths_mono_traversable hs-source-dirs: bench - ghc-options: -Wall -O2 + 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/mono-traversable/package.yaml b/mono-traversable/package.yaml index 4aac5078..8ecade0d 100644 --- a/mono-traversable/package.yaml +++ b/mono-traversable/package.yaml @@ -1,5 +1,5 @@ name: mono-traversable -version: 1.0.16.0 +version: 1.0.17.0 synopsis: Type classes for mapping, folding, and traversing monomorphic containers description: Please see the README at category: Data @@ -45,15 +45,23 @@ tests: - unordered-containers - foldl benchmarks: - sorting: - main: sorting.hs + all: + main: main.hs source-dirs: bench ghc-options: - -Wall - -O2 + - -with-rtsopts=-A32m + when: + - condition: impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 dependencies: - base - gauge - mono-traversable + - text + - containers + - bytestring - vector - mwc-random + - deepseq diff --git a/mono-traversable/src/Data/Sequences.hs b/mono-traversable/src/Data/Sequences.hs index 9bab565e..e6d05038 100644 --- a/mono-traversable/src/Data/Sequences.hs +++ b/mono-traversable/src/Data/Sequences.hs @@ -423,7 +423,7 @@ class (Monoid seq, MonoTraversable seq, SemiSequence seq, MonoPointed seq) => Is -- 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) @@ -472,6 +472,47 @@ class (Monoid seq, MonoTraversable seq, SemiSequence seq, MonoPointed seq) => Is 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 #-} @@ -502,6 +543,9 @@ class (Monoid seq, MonoTraversable seq, SemiSequence seq, MonoPointed seq) => Is {-# 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) @@ -607,6 +651,13 @@ instance IsSequence [a] where (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 #-} @@ -625,6 +676,9 @@ instance IsSequence [a] where {-# INLINE groupBy #-} {-# INLINE groupAllOn #-} {-# INLINE splitWhen #-} + {-# INLINE tails #-} + {-# INLINE inits #-} + {-# INLINE initTails #-} instance SemiSequence (NE.NonEmpty a) where type Index (NE.NonEmpty a) = Int @@ -961,6 +1015,12 @@ instance IsSequence (Seq.Seq a) where {-# 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 diff --git a/mono-traversable/test/Main.hs b/mono-traversable/test/Main.hs index befda4c3..e862269f 100644 --- a/mono-traversable/test/Main.hs +++ b/mono-traversable/test/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} @@ -13,7 +14,7 @@ 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.Monoid (mempty, mconcat, (<>)) import Data.Maybe (fromMaybe) import qualified Data.List as List @@ -39,13 +40,14 @@ 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) + return, asTypeOf, (.), Show, (+), succ, Maybe (..), (*), mod, map, flip, otherwise, (-), div, maybe, Char) import qualified Prelude newtype NonEmpty' a = NonEmpty' (NE.NonEmpty a) @@ -93,6 +95,10 @@ fromListAs xs _ = fromList xs 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 + main :: IO () main = hspec $ do describe "onull" $ do @@ -205,6 +211,51 @@ main = hspec $ do 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) + + 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) + + 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) + describe "NonNull" $ do describe "fromNonEmpty" $ do prop "toMinList" $ \(NonEmpty' ne) ->