Merge pull request #214 from BebeSparkelSparkel/master

tails, inits, initTails example implementation

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

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' (\() (_,_) -> ()) ()
+

mono-traversable/bench/sorting.hs → 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,17 +13,20 @@ 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
 
-main :: IO ()
-main = do
-    mapM mkGroup [10, 100, 1000, 10000] >>= defaultMain
-
 mkGroup :: Int -> IO Benchmark
 mkGroup size = do
     gen <- MWC.create

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
+  ]

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 <https://www.stackage.org/package/mono-traversable>
 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

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 <https://www.stackage.org/package/mono-traversable>
 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

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