acc 0.1.3 → 0.1.3.1
raw patch · 8 files changed
+362/−545 lines, 8 filesdep +gaugedep −criteriondep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: gauge
Dependencies removed: criterion
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- acc.cabal +5/−5
- bench/Main.hs +83/−0
- benchmark/Main.hs +0/−273
- library/Acc.hs +102/−96
- library/Acc/NeAcc.hs +3/−4
- library/Acc/NeAcc/Def.hs +98/−80
- library/Acc/Prelude.hs +20/−29
- test/Main.hs +51/−58
acc.cabal view
@@ -1,5 +1,5 @@ name: acc-version: 0.1.3+version: 0.1.3.1 synopsis: Sequence optimized for monoidal construction and folding description: Data structure intended for accumulating a sequence of elements@@ -35,13 +35,13 @@ Acc.NeAcc.Def Acc.Prelude build-depends:- base >=4.11 && <5,+ base >=4.13 && <5, deepseq >=1.4 && <1.5, semigroupoids >=5.3 && <6 -benchmark benchmark+benchmark bench type: exitcode-stdio-1.0- hs-source-dirs: benchmark+ hs-source-dirs: bench main-is: Main.hs default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples, ViewPatterns default-language: Haskell2010@@ -53,7 +53,7 @@ -funbox-strict-fields build-depends: acc,- criterion >=1.5.6 && <2,+ gauge >=0.2.5 && <0.3, rerebase >=1.9 && <2 test-suite test
+ bench/Main.hs view
@@ -0,0 +1,83 @@+module Main where++import qualified Acc+import qualified Data.DList as DList+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Sequence+import qualified Data.Vector as Vector+import Gauge+import Gauge.Main+import Prelude++main =+ defaultMain+ [ bgroup "sum" $+ [ onIntListByMagBench "cons" 3 $ \input ->+ [ reduceConstructBench "acc" input sum $+ foldl' (flip Acc.cons) mempty,+ reduceConstructBench "list" input sum $+ foldl' (flip (:)) [],+ reduceConstructBench "dlist" input sum $+ foldl' (flip DList.cons) mempty,+ reduceConstructBench "sequence" input sum $+ foldl' (flip (Sequence.<|)) mempty+ ],+ onIntListByMagBench "snoc" 3 $ \input ->+ [ reduceConstructBench "acc" input sum $+ foldl' (flip Acc.snoc) mempty,+ reduceConstructBench "dlist" input sum $+ foldl' DList.snoc mempty,+ reduceConstructBench "sequence" input sum $+ foldl' (Sequence.|>) mempty+ ],+ onIntListByMagBench "fromList" 3 $ \input ->+ [ reduceConstructBench "acc" input sum $ fromList @(Acc.Acc Int),+ reduceConstructBench "list" input sum $ id,+ reduceConstructBench "dlist" input sum $ DList.fromList,+ reduceConstructBench "sequence" input sum $ Sequence.fromList+ ]+ ],+ bgroup "length" $+ [ onIntListByMagBench "cons" 3 $ \input ->+ [ reduceConstructBench "acc" input length $+ foldl' (flip Acc.cons) mempty,+ reduceConstructBench "list" input length $+ foldl' (flip (:)) [],+ reduceConstructBench "dlist" input length $+ foldl' (flip DList.cons) mempty,+ reduceConstructBench "sequence" input length $+ foldl' (flip (Sequence.<|)) mempty+ ]+ ]+ ]++-- |+-- Construct a benchmark that measures construction of the intermediate representation+-- and reduction, ensuring that they don't get fused.+{-# NOINLINE reduceConstructBench #-}+reduceConstructBench ::+ NFData reduction =>+ -- | Benchmark name.+ String ->+ -- | Input sample.+ [a] ->+ -- | Reducer of the intermediate representation.+ (intermediate -> reduction) ->+ -- | Constructor of the intermediate representation.+ ([a] -> intermediate) ->+ Benchmark+reduceConstructBench name list reducer constructor =+ bench name $ nf (reducer . constructor) list++onIntListByMagBench :: String -> Int -> ([Int] -> [Benchmark]) -> Benchmark+onIntListByMagBench groupName amount benchmarks =+ onSizeByMagBench groupName amount $ \size ->+ benchmarks $!! enumFromTo 0 size++onSizeByMagBench :: String -> Int -> (Int -> [Benchmark]) -> Benchmark+onSizeByMagBench groupName amount benchmarks =+ bgroup groupName $+ take amount sizesByMagnitude <&> \size -> bgroup (show size) (benchmarks size)++sizesByMagnitude :: [Int]+sizesByMagnitude = [0 ..] <&> \magnitude -> 10 ^ (2 * magnitude)
− benchmark/Main.hs
@@ -1,273 +0,0 @@-module Main where--import Prelude-import Criterion-import Criterion.Main-import qualified Acc-import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import qualified Data.DList as DList-import qualified Data.Vector as Vector---main =- defaultMain [- sumBgroup "1"- (replicate 1000 1)- (foldMapToRight)- ,- sumBgroup "2"- (replicate 1000 1)- (foldMapToLeft)- ,- sumBgroup "sum/foldr',foldr'"- (Vector.fromList (replicate 100 (Vector.fromList (replicate @Int 100 1))))- (\ singleton -> foldr' (\ a b -> foldr' (mappend . singleton) mempty a <> b) mempty)- ,- sumBgroup "sum/foldl',foldl'"- (Vector.fromList (replicate 100 (Vector.fromList (replicate @Int 100 1))))- (\ singleton -> foldl' (\ a b -> a <> foldl' (\ a -> mappend a . singleton) mempty b) mempty)- ,- bgroup "thousand-elements" [- bgroup "foldl'" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldl' (<>) mempty $ fmap (pure @Acc.Acc) input- in Foldable.toList acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldl' (<>) mempty $ fmap Seq.singleton input- in Foldable.toList seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldl' (<>) mempty $ fmap DList.singleton input- in Foldable.toList seq- in nf work input- ]- ,- bgroup "foldr" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldr (<>) mempty $ fmap (pure @Acc.Acc) input- in Foldable.toList acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldr (<>) mempty $ fmap Seq.singleton input- in Foldable.toList seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldr (<>) mempty $ fmap DList.singleton input- in Foldable.toList seq- in nf work input- ]- ,- bgroup "foldr'" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldr' (<>) mempty $ fmap (pure @Acc.Acc) input- in Foldable.toList acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldr' (<>) mempty $ fmap Seq.singleton input- in Foldable.toList seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldr' (<>) mempty $ fmap DList.singleton input- in Foldable.toList seq- in nf work input- ]- ,- bgroup "foldr, force intermediate" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldr (<>) mempty $ fmap (pure @Acc.Acc) input- in Foldable.toList $!! acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldr (<>) mempty $ fmap Seq.singleton input- in Foldable.toList $!! seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldr (<>) mempty $ fmap DList.singleton input- in Foldable.toList $!! seq- in nf work input- ]- ,- bgroup "foldMap" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldMap (pure @Acc.Acc) input- in Foldable.toList acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldMap Seq.singleton input- in Foldable.toList seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldMap DList.singleton input- in Foldable.toList seq- in nf work input- ]- ,- bgroup "foldMap'" $ let- !input =- force $ enumFromTo 0 999 :: [Int]- in [- bench "Acc" $ let- work input =- let- acc =- foldMap' (pure @Acc.Acc) input- in Foldable.toList acc- in nf work input- ,- bench "Seq" $ let- work input =- let- seq =- foldMap' Seq.singleton input- in Foldable.toList seq- in nf work input- ,- bench "DList" $ let- work input =- let- seq =- foldMap' DList.singleton input- in Foldable.toList seq- in nf work input- ]- ]- ,- bgroup "groups" [- bgroup "foldl'" [- bench "acc" $ let- input :: [Acc.Acc Int]- !input =- enumFromTo 0 99 & fmap pure &- foldl' (<>) mempty &- replicate 10 &- force- work =- Foldable.toList . foldl' (<>) mempty- in nf work input- ,- bench "seq" $ let- input :: [Seq Int]- !input =- enumFromTo 0 99 & fmap pure &- foldl' (<>) mempty &- replicate 10 &- force- work =- Foldable.toList . foldl' (<>) mempty- in nf work input- ,- bench "dlist" $ let- input :: [DList Int]- !input =- enumFromTo 0 99 & fmap pure &- foldl' (<>) mempty &- replicate 10 &- force- work =- Foldable.toList . foldl' (<>) mempty- in nf work input- ]- ]- ]--sumBgroup :: NFData input => String -> input -> (forall f. (Foldable f, Monoid (f Int)) => (Int -> f Int) -> input -> f Int) -> Benchmark-sumBgroup name (force -> !input) build =- bgroup name [- sumBench "Acc" (pure @Acc.Acc)- ,- sumBench "Seq" Seq.singleton- ,- sumBench "DList" DList.singleton- ,- sumBench "List" (pure @[])- ]- where- sumBench :: (Foldable f, Monoid (f Int)) => String -> (Int -> f Int) -> Benchmark- sumBench name singleton =- bench name (nf (Foldable.sum . build singleton) input)----{-| Best for Acc. -}-{-# NOINLINE foldMapToRight #-}-foldMapToRight :: Monoid m => (a -> m) -> [a] -> m-foldMapToRight pure =- foldl' (\ a b -> pure b <> a) mempty--{-| Worst for Acc. -}-{-# NOINLINE foldMapToLeft #-}-foldMapToLeft :: Monoid m => (a -> m) -> [a] -> m-foldMapToLeft pure =- foldl' (\ a b -> a <> pure b) mempty
library/Acc.hs view
@@ -1,48 +1,44 @@-{-# LANGUAGE CPP #-} module Acc-(- Acc,- cons,- snoc,- uncons,- unsnoc,- toNonEmpty,- toNeAcc,- enumFromTo,-)+ ( Acc,+ cons,+ snoc,+ uncons,+ unsnoc,+ toNonEmpty,+ toNeAcc,+ enumFromTo,+ ) where -import Acc.Prelude hiding (toNonEmpty, enumFromTo) import qualified Acc.NeAcc as NeAcc import qualified Acc.NeAcc.Def as NeAcc+import Acc.Prelude hiding (enumFromTo, toNonEmpty) import qualified Data.Foldable as Foldable import qualified Data.Semigroup.Foldable as Foldable1 --{-|-Data structure intended for accumulating a sequence of elements-for later traversal or folding.-Useful for implementing all kinds of builders on top.--Appending and prepending is always \(\mathcal{O}(1)\).--To produce a single element 'Acc' use 'pure'.-To produce a multielement 'Acc' use 'fromList'.-To combine use '<|>' or '<>' and other 'Alternative' and 'Monoid'-related utils.-To extract elements use 'Foldable' API.--The benchmarks show that for the described use-case this data-structure-is on average 2 times faster than 'Data.DList.DList' and 'Data.Sequence.Seq',-is on par with list when you always prepend elements and-is exponentially faster than list when you append.--Internally it is implemented as a simple binary tree-with all functions optimized to use tail recursion,-ensuring that you don\'t get stack overflow.--}-data Acc a =- EmptyAcc |- TreeAcc !(NeAcc.NeAcc a)+-- |+-- Data structure intended for accumulating a sequence of elements+-- for later traversal or folding.+-- Useful for implementing all kinds of builders on top.+--+-- Appending and prepending is always \(\mathcal{O}(1)\).+--+-- To produce a single element 'Acc' use 'pure'.+-- To produce a multielement 'Acc' use 'fromList'.+-- To combine use '<|>' or '<>' and other 'Alternative' and 'Monoid'-related utils.+-- To extract elements use 'Foldable' API.+--+-- The benchmarks show that for the described use-case this data-structure+-- is on average 2 times faster than 'Data.DList.DList' and 'Data.Sequence.Seq',+-- is on par with list when you always prepend elements and+-- is exponentially faster than list when you append.+--+-- Internally it is implemented as a simple binary tree+-- with all functions optimized to use tail recursion,+-- ensuring that you don\'t get stack overflow.+data Acc a+ = EmptyAcc+ | TreeAcc !(NeAcc.NeAcc a) deriving (Generic, Generic1) instance NFData a => NFData (Acc a)@@ -52,62 +48,70 @@ deriving instance Functor Acc instance Foldable Acc where+ {-# INLINE [0] foldMap #-} foldMap f =- \ case+ \case TreeAcc a -> foldMap f a EmptyAcc -> mempty-#if MIN_VERSION_base(4,13,0)+ {-# INLINE [0] foldMap' #-} foldMap' f =- \ case+ \case TreeAcc a -> foldMap' f a EmptyAcc -> mempty-#endif+ {-# INLINE [0] foldr #-} foldr step acc =- \ case+ \case TreeAcc a -> foldr step acc a EmptyAcc -> acc+ {-# INLINE [0] foldr' #-} foldr' step acc =- \ case+ \case TreeAcc a -> foldr' step acc a EmptyAcc -> acc+ {-# INLINE [0] foldl #-} foldl step acc =- \ case+ \case TreeAcc a -> foldl step acc a EmptyAcc -> acc+ {-# INLINE [0] foldl' #-} foldl' step acc =- \ case+ \case TreeAcc a -> foldl' step acc a EmptyAcc -> acc+ {-# INLINE [0] sum #-} sum = foldl' (+) 0 instance Traversable Acc where+ {-# INLINE [0] traverse #-} traverse f =- \ case+ \case TreeAcc a -> TreeAcc <$> traverse f a EmptyAcc -> pure EmptyAcc instance Applicative Acc where+ {-# INLINE [1] pure #-} pure = TreeAcc . NeAcc.Leaf+ {-# INLINE [1] (<*>) #-} (<*>) =- \ case+ \case TreeAcc a ->- \ case+ \case TreeAcc b -> TreeAcc (a <*> b) EmptyAcc ->@@ -116,12 +120,14 @@ const EmptyAcc instance Alternative Acc where+ {-# INLINE [1] empty #-} empty = EmptyAcc+ {-# INLINE [1] (<|>) #-} (<|>) =- \ case+ \case TreeAcc a ->- \ case+ \case TreeAcc b -> TreeAcc (NeAcc.Branch a b) EmptyAcc ->@@ -130,23 +136,25 @@ id instance Semigroup (Acc a) where+ {-# INLINE [1] (<>) #-} (<>) = (<|>) instance Monoid (Acc a) where+ {-# INLINE [1] mempty #-} mempty = empty- mappend =- (<>) instance IsList (Acc a) where type Item (Acc a) = a- fromList =- \ case- a : b -> TreeAcc (NeAcc.fromList1 a b)+ {-# INLINE [0] fromList #-}+ fromList list =+ case reverse list of+ a : b -> TreeAcc (NeAcc.prependReverseList b (NeAcc.Leaf a)) _ -> EmptyAcc+ {-# INLINE [0] toList #-} toList =- \ case+ \case TreeAcc a -> foldr (:) [] a _ ->@@ -156,28 +164,28 @@ show = show . toList -{-|-Prepend an element.--}+-- |+-- Prepend an element.+{-# INLINE [1] cons #-} cons :: a -> Acc a -> Acc a cons a =- \ case+ \case TreeAcc tree -> TreeAcc (NeAcc.Branch (NeAcc.Leaf a) tree) EmptyAcc -> TreeAcc (NeAcc.Leaf a) -{-|-Extract the first element.--The produced accumulator will lack the extracted element-and will have the underlying tree rebalanced towards the beginning.-This means that calling 'uncons' on it will be \(\mathcal{O}(1)\) and-'unsnoc' will be \(\mathcal{O}(n)\).--}+-- |+-- Extract the first element.+--+-- The produced accumulator will lack the extracted element+-- and will have the underlying tree rebalanced towards the beginning.+-- This means that calling 'uncons' on it will be \(\mathcal{O}(1)\) and+-- 'unsnoc' will be \(\mathcal{O}(n)\).+{-# INLINE uncons #-} uncons :: Acc a -> Maybe (a, Acc a) uncons =- \ case+ \case TreeAcc tree -> case tree of NeAcc.Branch l r ->@@ -189,28 +197,28 @@ EmptyAcc -> Nothing -{-|-Append an element.--}+-- |+-- Append an element.+{-# INLINE [1] snoc #-} snoc :: a -> Acc a -> Acc a snoc a =- \ case+ \case TreeAcc tree -> TreeAcc (NeAcc.Branch tree (NeAcc.Leaf a)) EmptyAcc -> TreeAcc (NeAcc.Leaf a) -{-|-Extract the last element.--The produced accumulator will lack the extracted element-and will have the underlying tree rebalanced towards the end.-This means that calling 'unsnoc' on it will be \(\mathcal{O}(1)\) and-'uncons' will be \(\mathcal{O}(n)\).--}+-- |+-- Extract the last element.+--+-- The produced accumulator will lack the extracted element+-- and will have the underlying tree rebalanced towards the end.+-- This means that calling 'unsnoc' on it will be \(\mathcal{O}(1)\) and+-- 'uncons' will be \(\mathcal{O}(n)\).+{-# INLINE unsnoc #-} unsnoc :: Acc a -> Maybe (a, Acc a) unsnoc =- \ case+ \case TreeAcc tree -> case tree of NeAcc.Branch l r ->@@ -222,31 +230,29 @@ EmptyAcc -> Nothing -{-|-Convert to non empty list if it's not empty.--}+-- |+-- Convert to non empty list if it's not empty.+{-# INLINE toNonEmpty #-} toNonEmpty :: Acc a -> Maybe (NonEmpty a) toNonEmpty = fmap Foldable1.toNonEmpty . toNeAcc -{-|-Convert to non empty acc if it's not empty.--}+-- |+-- Convert to non empty acc if it's not empty.+{-# INLINE toNeAcc #-} toNeAcc :: Acc a -> Maybe (NeAcc.NeAcc a) toNeAcc =- \ case+ \case TreeAcc tree -> Just tree EmptyAcc -> Nothing -{-|-Enumerate in range, inclusively.--}+-- |+-- Enumerate in range, inclusively.+{-# INLINE [1] enumFromTo #-} enumFromTo :: (Enum a, Ord a) => a -> a -> Acc a enumFromTo from to = if from <= to- then- TreeAcc (NeAcc.appendEnumFromTo (succ from) to (NeAcc.Leaf from))- else- EmptyAcc+ then TreeAcc (NeAcc.appendEnumFromTo (succ from) to (NeAcc.Leaf from))+ else EmptyAcc
library/Acc/NeAcc.hs view
@@ -1,8 +1,7 @@ module Acc.NeAcc-(- NeAcc,-)+ ( NeAcc,+ ) where -import Acc.Prelude import Acc.NeAcc.Def+import Acc.Prelude
library/Acc/NeAcc/Def.hs view
@@ -1,29 +1,25 @@-{-# LANGUAGE CPP #-} module Acc.NeAcc.Def-(- NeAcc(..),- foldM,- fromList1,- uncons,- unconsTo,- unsnoc,- unsnocTo,- appendEnumFromTo,-)+ ( NeAcc (..),+ foldM,+ prependReverseList,+ uncons,+ unconsTo,+ unsnoc,+ unsnocTo,+ appendEnumFromTo,+ ) where import Acc.Prelude hiding (foldM) import qualified Acc.Prelude as Prelude --{-|-Non-empty accumulator.--Relates to 'Acc.Acc' the same way as 'NonEmpty' to list.--}-data NeAcc a =- Leaf !a |- Branch !(NeAcc a) !(NeAcc a)+-- |+-- Non-empty accumulator.+--+-- Relates to 'Acc.Acc' the same way as 'NonEmpty' to list.+data NeAcc a+ = Leaf !a+ | Branch !(NeAcc a) !(NeAcc a) deriving (Generic, Generic1) instance Show a => Show (NeAcc a) where@@ -36,10 +32,12 @@ instance IsList (NeAcc a) where type Item (NeAcc a) = a- fromList =- \ case- a : b -> fromList1 a b+ {-# INLINE [0] fromList #-}+ fromList list =+ case reverse list of+ a : b -> prependReverseList b (Leaf a) _ -> error "Empty input list"+ {-# INLINE [0] toList #-} toList = foldr (:) [] @@ -48,53 +46,56 @@ instance Applicative NeAcc where pure = Leaf+ {-# INLINE [1] (<*>) #-} (<*>) =- \ case+ \case Branch a b ->- \ c ->+ \c -> Branch (a <*> c) (b <*> c) Leaf a ->- fmap a + fmap a instance Foldable NeAcc where- + {-# INLINEABLE [0] foldr #-} foldr :: (a -> b -> b) -> b -> NeAcc a -> b foldr step acc = peel [] where peel layers =- \ case+ \case Leaf a -> step a (unpeel layers) Branch l r -> peel (r : layers) l unpeel =- \ case+ \case h : t -> peel t h _ -> acc + {-# INLINE [0] foldr' #-} foldr' :: (a -> b -> b) -> b -> NeAcc a -> b foldr' step = peel [] where peel layers acc =- \ case+ \case Leaf a -> unpeel (step a acc) layers Branch l r -> peel (l : layers) acc r unpeel !acc =- \ case+ \case h : t -> peel t acc h _ -> acc + {-# INLINE [0] foldl #-} foldl :: (b -> a -> b) -> b -> NeAcc a -> b foldl step acc =- \ case+ \case Branch a b -> foldlOnBranch step acc a b Leaf a ->@@ -108,9 +109,10 @@ Branch c d -> foldlOnBranch step acc (Branch a c) d + {-# INLINE [0] foldl' #-} foldl' :: (b -> a -> b) -> b -> NeAcc a -> b foldl' step !acc =- \ case+ \case Branch a b -> foldlOnBranch' step acc a b Leaf a ->@@ -124,29 +126,32 @@ Branch c d -> foldlOnBranch' step acc c (Branch d b) + {-# INLINE [0] foldMap #-} foldMap :: Monoid m => (a -> m) -> NeAcc a -> m- foldMap =- foldMapTo mempty+ foldMap map =+ peel where- foldMapTo :: Monoid m => m -> (a -> m) -> NeAcc a -> m- foldMapTo acc map =- \ case- Branch a b -> foldMapToOnBranch acc map a b- Leaf a -> acc <> map a- foldMapToOnBranch :: Monoid m => m -> (a -> m) -> NeAcc a -> NeAcc a -> m- foldMapToOnBranch acc map a b =- case a of- Leaf c -> foldMapTo (acc <> map c) map b- Branch c d -> foldMapToOnBranch acc map c (Branch d b)+ peel =+ \case+ Branch a b ->+ peelLeftStacking b a+ Leaf a ->+ map a+ peelLeftStacking buff =+ \case+ Branch a b ->+ peelLeftStacking (Branch b buff) a+ Leaf a ->+ map a <> peel buff -#if MIN_VERSION_base(4,13,0)+ {-# INLINE [0] foldMap' #-} foldMap' :: Monoid m => (a -> m) -> NeAcc a -> m foldMap' = foldMapTo' mempty where foldMapTo' :: Monoid m => m -> (a -> m) -> NeAcc a -> m foldMapTo' !acc map =- \ case+ \case Branch a b -> foldMapToOnBranch' acc map a b Leaf a -> acc <> map a foldMapToOnBranch' :: Monoid m => m -> (a -> m) -> NeAcc a -> NeAcc a -> m@@ -154,13 +159,27 @@ case a of Leaf c -> foldMapTo' (acc <> map c) map b Branch c d -> foldMapToOnBranch' acc map c (Branch d b)-#endif -instance Traversable NeAcc where+ {-# INLINE length #-}+ length :: NeAcc a -> Int+ length =+ \case+ Leaf _ -> 1+ Branch l r -> go 0 l r+ where+ go n l r =+ case l of+ Leaf _ -> case succ n of+ n -> case r of+ Branch l r -> go n l r+ Leaf _ -> succ n+ Branch l lr -> go n l (Branch lr r) +instance Traversable NeAcc where+ {-# INLINE [0] traverse #-} traverse :: Applicative f => (a -> f b) -> NeAcc a -> f (NeAcc b) traverse map =- \ case+ \case Branch a b -> traverseOnBranch map a b Leaf a ->@@ -170,34 +189,36 @@ traverseOnBranch map a b = case a of Leaf c ->- Branch <$> Leaf <$> map c <*> traverse map b+ Branch . Leaf <$> map c <*> traverse map b Branch c d -> traverseOnBranch map a (Branch d b) instance Foldable1 NeAcc where-+ {-# INLINE [0] fold1 #-} fold1 :: Semigroup m => NeAcc m -> m fold1 =- \ case+ \case Branch l r -> rebalancingLeft l r (foldl' (<>)) Leaf a -> a + {-# INLINE [0] foldMap1 #-} foldMap1 :: Semigroup m => (a -> m) -> NeAcc a -> m foldMap1 f =- \ case+ \case Branch l r ->- rebalancingLeft l r (foldl' (\ m a -> m <> f a) . f)+ rebalancingLeft l r (foldl' (\m a -> m <> f a) . f) Leaf a -> f a + {-# INLINE [0] toNonEmpty #-} toNonEmpty :: NeAcc a -> NonEmpty a toNonEmpty = findFirst where findFirst =- \ case+ \case Branch l r -> findFirstOnBranch l r Leaf a ->@@ -210,9 +231,9 @@ a :| foldr (:) [] r instance Traversable1 NeAcc where-+ {-# INLINE [0] traverse1 #-} traverse1 map =- \ case+ \case Branch a b -> traverseOnBranch map a b Leaf a ->@@ -221,18 +242,21 @@ traverseOnBranch map a b = case a of Leaf c ->- Branch <$> Leaf <$> map c <.> traverse1 map b+ Branch . Leaf <$> map c <.> traverse1 map b Branch c d -> traverseOnBranch map a (Branch d b) instance Alt NeAcc where+ {-# INLINE [1] (<!>) #-} (<!>) = Branch instance Semigroup (NeAcc a) where+ {-# INLINE [1] (<>) #-} (<>) = Branch +{-# INLINE rebalancingLeft #-} rebalancingLeft :: NeAcc a -> NeAcc a -> (a -> NeAcc a -> b) -> b rebalancingLeft l r cont = case l of@@ -243,39 +267,35 @@ foldM :: Monad m => (a -> b -> m a) -> a -> NeAcc b -> m a foldM step !acc =- \ case+ \case Branch a b -> foldMOnBranch step acc a b Leaf a -> step acc a where foldMOnBranch :: Monad m => (a -> b -> m a) -> a -> NeAcc b -> NeAcc b -> m a foldMOnBranch step acc a b = case a of- Leaf c -> step acc c >>= \ acc' -> foldM step acc' b+ Leaf c -> step acc c >>= \acc' -> foldM step acc' b Branch c d -> foldMOnBranch step acc c (Branch d b) -fromList1 :: a -> [a] -> NeAcc a-fromList1 a =- \ case- b : c -> fromList1To (Leaf a) b c- _ -> Leaf a--fromList1To :: NeAcc a -> a -> [a] -> NeAcc a-fromList1To leftTree a =- \ case- b : c -> fromList1To (Branch leftTree (Leaf a)) b c- _ -> Branch leftTree (Leaf a)+prependReverseList :: [a] -> NeAcc a -> NeAcc a+prependReverseList list tree =+ case list of+ head : tail -> prependReverseList tail (Branch (Leaf head) tree)+ _ -> tree +{-# INLINE uncons #-} uncons :: NeAcc a -> (a, Maybe (NeAcc a)) uncons =- \ case+ \case Branch l r -> fmap Just (unconsTo r l) Leaf a -> (a, Nothing) +{-# INLINE unconsTo #-} unconsTo :: NeAcc a -> NeAcc a -> (a, NeAcc a) unconsTo buff =- \ case+ \case Branch l r -> unconsTo (Branch r buff) l Leaf a ->@@ -283,7 +303,7 @@ unsnoc :: NeAcc a -> (a, Maybe (NeAcc a)) unsnoc =- \ case+ \case Branch l r -> fmap Just (unsnocTo l r) Leaf a ->@@ -291,7 +311,7 @@ unsnocTo :: NeAcc a -> NeAcc a -> (a, NeAcc a) unsnocTo buff =- \ case+ \case Branch l r -> unsnocTo (Branch l buff) r Leaf a ->@@ -300,7 +320,5 @@ appendEnumFromTo :: (Enum a, Ord a) => a -> a -> NeAcc a -> NeAcc a appendEnumFromTo from to = if from <= to- then- appendEnumFromTo (succ from) to . flip Branch (Leaf from)- else- id+ then appendEnumFromTo (succ from) to . flip Branch (Leaf from)+ else id
library/Acc/Prelude.hs view
@@ -1,20 +1,18 @@ module Acc.Prelude-( - module Exports,-)+ ( module Exports,+ ) where --- base-------------------------- import Control.Applicative as Exports import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports+import Control.DeepSeq as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports@@ -29,19 +27,23 @@ import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports+import Data.Functor.Alt as Exports hiding (many, optional, some)+import Data.Functor.Apply as Exports import Data.Functor.Compose as Exports-import Data.Int as Exports import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Alt, First(..), Last(..), (<>))+import Data.Monoid as Exports hiding (Alt, First (..), Last (..), (<>)) import Data.Ord as Exports import Data.Proxy as Exports import Data.Ratio as Exports-import Data.Semigroup as Exports import Data.STRef as Exports+import Data.Semigroup as Exports+import Data.Semigroup.Foldable as Exports+import Data.Semigroup.Traversable as Exports import Data.String as Exports import Data.Traversable as Exports import Data.Tuple as Exports@@ -54,12 +56,11 @@ import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic, Generic1) import GHC.IO.Exception as Exports import Numeric as Exports-import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose)@@ -69,18 +70,8 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- deepseq---------------------------import Control.DeepSeq as Exports---- semigroupoids---------------------------import Data.Functor.Alt as Exports hiding (some, many, optional)-import Data.Functor.Apply as Exports-import Data.Semigroup.Foldable as Exports-import Data.Semigroup.Traversable as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))
test/Main.hs view
@@ -1,66 +1,59 @@ module Main where -import Prelude hiding (assert)+import Acc+import qualified Data.List.NonEmpty as NonEmpty import GHC.Exts (fromList)+import qualified Test.QuickCheck as QuickCheck import Test.QuickCheck.Instances import Test.Tasty-import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import Acc-import qualified Test.QuickCheck as QuickCheck-import qualified Data.List.NonEmpty as NonEmpty-+import Test.Tasty.Runners+import Prelude hiding (assert) main =- defaultMain $ - testGroup "All tests" [- testProperty "Acc converted to list and reconstructed from it converts to the same list again" $- \ (acc :: Acc Int) -> let- list =- toList acc- acc' :: Acc Int- acc' =- fromList list- list' =- toList acc'- in list === list'- ,- testProperty "foldl" $- \ (acc :: Acc Int) ->- foldl (flip (:)) [] acc ===- foldl (flip (:)) [] (toList acc)- ,- testProperty "foldl'" $- \ (acc :: Acc Int) ->- foldl' (flip (:)) [] acc ===- foldl' (flip (:)) [] (toList acc)- ,- testProperty "foldr" $- \ (acc :: Acc Int) ->- foldr (:) [] acc ===- foldr (:) [] (toList acc)- ,- testProperty "foldr'" $- \ (acc :: Acc Int) ->- foldr' (:) [] acc ===- foldr' (:) [] (toList acc)- ,- testProperty "foldMap" $- \ (acc :: Acc Int) ->- foldMap (: []) acc ===- foldMap (: []) (toList acc)- ,- testProperty "foldMap'" $- \ (acc :: Acc Int) ->- foldMap' (: []) acc ===- foldMap' (: []) (toList acc)- ,- testProperty "toNonEmpty" $- \ (acc :: Acc Int) ->- Acc.toNonEmpty acc ===- NonEmpty.nonEmpty (toList acc)- ]+ defaultMain $+ testGroup+ "All tests"+ [ testProperty "Acc converted to list and reconstructed from it converts to the same list again" $+ \(acc :: Acc Int) ->+ let list =+ toList acc+ acc' :: Acc Int+ acc' =+ fromList list+ list' =+ toList acc'+ in list === list',+ testProperty "foldl" $+ \(acc :: Acc Int) ->+ foldl (flip (:)) [] acc+ === foldl (flip (:)) [] (toList acc),+ testProperty "foldl'" $+ \(acc :: Acc Int) ->+ foldl' (flip (:)) [] acc+ === foldl' (flip (:)) [] (toList acc),+ testProperty "foldr" $+ \(acc :: Acc Int) ->+ foldr (:) [] acc+ === foldr (:) [] (toList acc),+ testProperty "foldr'" $+ \(acc :: Acc Int) ->+ foldr' (:) [] acc+ === foldr' (:) [] (toList acc),+ testProperty "foldMap" $+ \(acc :: Acc Int) ->+ foldMap (: []) acc+ === foldMap (: []) (toList acc),+ testProperty "foldMap'" $+ \(acc :: Acc Int) ->+ foldMap' (: []) acc+ === foldMap' (: []) (toList acc),+ testProperty "toNonEmpty" $+ \(acc :: Acc Int) ->+ Acc.toNonEmpty acc+ === NonEmpty.nonEmpty (toList acc)+ ] instance Arbitrary a => Arbitrary (Acc a) where arbitrary =@@ -68,10 +61,10 @@ accGen :: Gen a -> Gen (Acc a) accGen aGen =- oneof [- listAccGen aGen,- appendAccGen aGen,- pureAccGen aGen+ oneof+ [ listAccGen aGen,+ appendAccGen aGen,+ pureAccGen aGen ] listAccGen :: Gen a -> Gen (Acc a)