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..4c98c8dc --- /dev/null +++ b/mono-traversable/bench/InitTails.hs @@ -0,0 +1,90 @@ +{-# 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]) + , ("extream", [1000000]) + ] + +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 ce23ff35..1baf9a93 100644 --- a/mono-traversable/mono-traversable.cabal +++ b/mono-traversable/mono-traversable.cabal @@ -1,6 +1,6 @@ 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 @@ -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 3b46d56e..8ecade0d 100644 --- a/mono-traversable/package.yaml +++ b/mono-traversable/package.yaml @@ -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 e3d89881..e6d05038 100644 --- a/mono-traversable/src/Data/Sequences.hs +++ b/mono-traversable/src/Data/Sequences.hs @@ -711,9 +711,6 @@ instance SemiSequence S.ByteString where {-# INLINE cons #-} {-# INLINE snoc #-} -initTailsViaSplitAt :: IsSequence seq => seq -> [(seq, seq)] -initTailsViaSplitAt x = fmap (`splitAt` x) [0 .. lengthIndex x] - instance IsSequence S.ByteString where fromList = S.pack lengthIndex = S.length @@ -769,9 +766,6 @@ instance IsSequence S.ByteString where {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} - initTails = initTailsViaSplitAt - {-# INLINE initTails #-} - instance SemiSequence T.Text where type Index T.Text = Int intersperse = T.intersperse @@ -836,9 +830,6 @@ instance IsSequence T.Text where {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} - initTails = initTailsViaSplitAt - {-# INLINE initTails #-} - instance SemiSequence L.ByteString where type Index L.ByteString = Int64 intersperse = L.intersperse @@ -1027,7 +1018,8 @@ instance IsSequence (Seq.Seq a) where initTails = its . (,) mempty where its x@(is, y Seq.:<| ts) = x : its (is Seq.:|> y, ts) - its (_, Seq.Empty) = mempty + its x@(_, Seq.Empty) = [x] + {-# INLINE initTails #-} instance SemiSequence (V.Vector a) where type Index (V.Vector a) = Int @@ -1102,9 +1094,6 @@ instance IsSequence (V.Vector a) where {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} - initTails = initTailsViaSplitAt - {-# INLINE initTails #-} - instance U.Unbox a => SemiSequence (U.Vector a) where type Index (U.Vector a) = Int @@ -1178,9 +1167,6 @@ instance U.Unbox a => IsSequence (U.Vector a) where {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} - initTails = initTailsViaSplitAt - {-# INLINE initTails #-} - instance VS.Storable a => SemiSequence (VS.Vector a) where type Index (VS.Vector a) = Int reverse = VS.reverse @@ -1254,9 +1240,6 @@ instance VS.Storable a => IsSequence (VS.Vector a) where {-# INLINE indexEx #-} {-# INLINE unsafeIndex #-} - initTails = initTailsViaSplitAt - {-# INLINE initTails #-} - -- | @'splitElem'@ splits a sequence into components delimited by separator -- element. It's equivalent to 'splitWhen' with equality predicate: -- diff --git a/mono-traversable/test/Main.hs b/mono-traversable/test/Main.hs index 94457e1f..4b39b20b 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 #-} @@ -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 @@ -232,11 +238,15 @@ main = hspec $ 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 "String" (mempty :: String) + 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