hw-fingertree-strict 0.1.0.2 → 0.1.0.3

raw patch · 10 files changed

+317/−25 lines, 10 filesdep +deepseqnew-uploaderPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• hw-fingertree-strict.cabal +5/−2
• src/HaskellWorks/Data/FingerTree/Strict.hs +8/−6
• src/HaskellWorks/Data/IntervalMap/Strict.hs +7/−1
• src/HaskellWorks/Data/Item/Strict.hs +5/−1
• src/HaskellWorks/Data/PriorityQueue/Strict.hs +3/−0
• src/HaskellWorks/Data/Segment/Strict.hs +5/−1
• src/HaskellWorks/Data/SegmentMap/Strict.hs +9/−7
• src/HaskellWorks/Data/SegmentSet/Strict.hs +9/−7
• test/HaskellWorks/Data/FingerTree/Gen.hs +55/−0
• test/HaskellWorks/Data/FingerTreeSpec.hs +211/−0

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: cf96e753aa89a6ce71fe493132b754969cc657812d4d88482f673fee7fe3a96c+-- hash: f1b862b22d5d83cf314a1c9f6c15e9533377a9225218e6b3bd7693aa5a50f50b  name:           hw-fingertree-strict-version:        0.1.0.2+version:        0.1.0.3 synopsis:       Generic strict finger-tree structure description:    A general sequence representation with arbitrary                 annotations, for use as a base for implementations of@@ -44,6 +44,7 @@       src   build-depends:       base >=4.7 && <5+    , deepseq   if !(impl(ghc >=8.0))     build-depends:         semigroups ==0.18.*@@ -78,8 +79,10 @@     , test-framework-hunit     , test-framework-quickcheck2   other-modules:+      HaskellWorks.Data.FingerTree.Gen       HaskellWorks.Data.FingerTree.Strict.Gen       HaskellWorks.Data.FingerTree.StrictSpec+      HaskellWorks.Data.FingerTreeSpec       HaskellWorks.Data.Gen       HaskellWorks.Data.SegmentMap.StrictSpec       HaskellWorks.Data.SegmentSet.Naive

@@ -65,8 +65,10 @@ import Prelude hiding (null, reverse)  import Control.Applicative (Applicative (pure, (<*>)), (<$>))+import Control.DeepSeq     (NFData) import Data.Foldable       (Foldable (foldMap), foldr', toList) import Data.Monoid+import GHC.Generics        (Generic)  import qualified Data.Semigroup as S @@ -78,14 +80,14 @@ data ViewL s a     = EmptyL        -- ^ empty sequence     | !a :< !(s a)  -- ^ leftmost element and the rest of the sequence-    deriving (Eq, Ord, Show, Read)+    deriving (Eq, Ord, Show, Read, Generic, NFData)  -- | View of the right end of a sequence. data ViewR s a     = EmptyR        -- ^ empty sequence     | !(s a) :> !a      -- ^ the sequence minus the rightmost element,                     -- and the rightmost element-    deriving (Eq, Ord, Show, Read)+    deriving (Eq, Ord, Show, Read, Generic, NFData)  instance Functor s => Functor (ViewL s) where     fmap _ EmptyL    = EmptyL@@ -114,7 +116,7 @@     | Two !a !a     | Three !a !a !a     | Four !a !a !a !a-    deriving Show+    deriving (Eq, Show, Generic, NFData)  instance Foldable Digit where     foldMap f (One a)        = f a@@ -138,7 +140,7 @@ ---------------------------  data Node v a = Node2 !v !a !a | Node3 !v !a !a !a-    deriving Show+    deriving (Show, Generic, NFData)  instance Foldable (Node v) where     foldMap f (Node2 _ a b)   = f a `mappend` f b@@ -173,7 +175,7 @@     = Empty     | Single !a     | Deep !v !(Digit a) !(FingerTree v (Node v a)) !(Digit a)-    deriving (Show)+    deriving (Show, Generic, NFData)  deep ::  (Measured v a) =>      Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a@@ -737,7 +739,7 @@ dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a dropUntil p  =  snd . split p -data Split t a = Split !t !a !t+data Split t a = Split !t !a !t deriving (Eq, Show, Generic, NFData)  splitTree :: (Measured v a) =>     (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a

@@ -45,9 +45,11 @@     ) where  import Control.Applicative                 ((<$>))+import Control.DeepSeq                     (NFData) import Data.Foldable                       (Foldable (foldMap)) import Data.Monoid import Data.Traversable                    (Traversable (traverse))+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), (<|), (><))  import qualified Data.Semigroup                      as S@@ -60,13 +62,14 @@ -- | A closed interval.  The lower bound should be less than or equal -- to the higher bound. data Interval v = Interval { low :: !v, high :: !v }-    deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic, NFData)  -- | An interval in which the lower and upper bounds are equal. point :: v -> Interval v point v = Interval v v  data Node v a = Node !(Interval v) !a+  deriving (Eq, Show, Generic, NFData)  instance Functor (Node v) where     fmap f (Node i x) = Node i (f x)@@ -79,6 +82,7 @@  -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval !(Interval v) !v+  deriving (Eq, Show, Generic, NFData)  appendInterval :: Ord v => IntInterval v -> IntInterval v -> IntInterval v appendInterval (NoInterval       ) (i                   ) = i@@ -104,6 +108,8 @@ -- lexicographical order. newtype IntervalMap v a =     IntervalMap (FingerTree (IntInterval v) (Node v a))+  deriving (Eq, Show, Generic, NFData)+ -- ordered lexicographically by interval  instance Functor (IntervalMap v) where

@@ -1,11 +1,15 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}  module HaskellWorks.Data.Item.Strict where +import Control.DeepSeq                     (NFData)+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict -data Item k a = Item !k !a deriving (Eq, Show)+data Item k a = Item !k !a deriving (Eq, Show, Generic, NFData)  instance Functor (Item k) where     fmap f (Item i t) = Item i (f t)

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe                  #-}@@ -55,8 +56,10 @@     ) where  import Control.Arrow                       ((***))+import Control.DeepSeq                     (NFData) import Data.Foldable                       (Foldable (foldMap)) import Data.Monoid+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), (<|), (><), (|>)) import Prelude                             hiding (null) 

@@ -1,14 +1,18 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}  module HaskellWorks.Data.Segment.Strict where +import Control.DeepSeq                     (NFData)+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict  -- | A closed segment.  The lower bound should be less than or equal -- to the higher bound. data Segment k = Segment { low :: !k, high :: !k }-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic, NFData)  -- | A segment in which the lower and upper bounds are equal. point :: k -> Segment k

@@ -1,6 +1,7 @@ -- {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -56,17 +57,18 @@     cappedM     ) where +import Control.Applicative                 ((<$>))+import Control.DeepSeq                     (NFData)+import Data.Foldable                       (Foldable (foldMap), foldl', toList)+import Data.Semigroup+import Data.Traversable                    (Traversable (traverse))+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict (FingerTree, ViewL (..), ViewR (..), viewl, viewr, (<|), (><)) import HaskellWorks.Data.Item.Strict import HaskellWorks.Data.Segment.Strict  import qualified HaskellWorks.Data.FingerTree.Strict as FT -import Control.Applicative ((<$>))-import Data.Foldable       (Foldable (foldMap), foldl', toList)-import Data.Semigroup-import Data.Traversable    (Traversable (traverse))- infixr 5 >*<  ----------------------------------@@ -77,9 +79,9 @@ -- The 'Foldable' and 'Traversable' instances process the segments in -- lexicographical order. -newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving Show+newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving (Show, Generic, NFData) -newtype SegmentMap k a = SegmentMap (OrderedMap (Max k) (Segment k, a)) deriving Show+newtype SegmentMap k a = SegmentMap (OrderedMap (Max k) (Segment k, a)) deriving (Show, Generic, NFData)  -- ordered lexicographically by segment start 

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -59,17 +60,18 @@     cappedM     ) where +import Control.Applicative                 ((<$>))+import Control.DeepSeq                     (NFData)+import Data.Foldable                       (Foldable (foldMap), foldl', toList)+import Data.Semigroup+import Data.Traversable                    (Traversable (traverse))+import GHC.Generics                        (Generic) import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), ViewR (..), viewl, viewr, (<|), (><)) import HaskellWorks.Data.Item.Strict import HaskellWorks.Data.Segment.Strict  import qualified HaskellWorks.Data.FingerTree.Strict as FT -import Control.Applicative ((<$>))-import Data.Foldable       (Foldable (foldMap), foldl', toList)-import Data.Semigroup-import Data.Traversable    (Traversable (traverse))- {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}  infixr 5 >*<@@ -82,9 +84,9 @@ -- The 'Foldable' and 'Traversable' instances process the segments in -- lexicographical order. -newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving Show+newtype OrderedMap k a = OrderedMap (FingerTree k (Item k a)) deriving (Show, Generic, NFData) -newtype SegmentSet k = SegmentSet (OrderedMap (Max k) (Segment k)) deriving Show+newtype SegmentSet k = SegmentSet (OrderedMap (Max k) (Segment k)) deriving (Show, Generic, NFData)  -- ordered lexicographically by segment start 

@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}++module HaskellWorks.Data.FingerTree.Gen where++import Control.Monad+import HaskellWorks.Data.FingerTree.Strict+import Hedgehog++import qualified Hedgehog.Gen             as G+import qualified Hedgehog.Internal.Gen    as G+import qualified Hedgehog.Internal.Shrink as S+import qualified Hedgehog.Range           as R++genList :: MonadGen m => Range Int -> m a -> m [a]+genList range gen =+  G.sized $ \size ->+    (traverse snd =<<) .+    G.ensure (G.atLeast $ R.lowerBound size range) .+    G.shrink S.list $ do+      k <- G.integral_ range+      replicateM k (G.freeze gen)++shrinkFingerTree :: Measured v a => FingerTree v a -> [FingerTree v a]+shrinkFingerTree (Deep _ (One a) Empty (One b)) = [Single a, Single b]+shrinkFingerTree (Deep _ pr m sf) =+    [deep pr' m  sf  | pr' <- shrinkDigit      pr] +++    [deep pr  m' sf  | m'  <- shrinkFingerTree m ] +++    [deep pr  m  sf' | sf' <- shrinkDigit      sf]+shrinkFingerTree (Single x) = []+shrinkFingerTree Empty = []++fingerTree :: (MonadGen m, Measured v a) => m a -> m (FingerTree v a)+fingerTree gen = G.sized $ \size -> genSizedFingerTree size gen++genSizedFingerTree :: (MonadGen m, Measured v a) => Size -> m a -> m (FingerTree v a)+genSizedFingerTree n gen = G.shrink shrinkFingerTree $ case n of+    0 -> return Empty+    1 -> Single <$> gen+    n -> deep <$> (One <$> gen) <*> genSizedFingerTree (n `div` 2) (genSizedNode (n `div` 2) gen) <*> (One <$> gen)++shrinkNode :: Measured v a => Node v a -> [Node v a]+shrinkNode (Node2 _ a b)   = []+shrinkNode (Node3 _ a b c) = [node2 a  b, node2 a c, node2 b c]++genSizedNode :: (MonadGen m, Measured v a) => Size -> m a -> m (Node v a)+genSizedNode n gen = G.shrink shrinkNode $ G.choice+    [ node2 <$> gen <*> gen+    , node3 <$> gen <*> gen <*> gen+    ]++shrinkDigit :: Digit a -> [Digit a]+shrinkDigit (One a)        = []+shrinkDigit (Two a b)      = [One a, One b]+shrinkDigit (Three a b c)  = [Two a b, Two a c, Two b c]+shrinkDigit (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]

@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.FingerTreeSpec (spec) where++import Control.Applicative                 (Applicative (..))+import Control.Monad                       (ap)+import Data.Foldable                       (Foldable (foldMap, foldl, foldr), all, toList)+import Data.Functor                        ((<$>))+import Data.List                           (inits)+import Data.Monoid                         (Monoid (..))+import Data.Traversable                    (traverse)+import HaskellWorks.Data.FingerTree.Strict+import HaskellWorks.Hspec.Hedgehog+import Hedgehog                            hiding (evalM)+import Prelude                             hiding (null, reverse)+import Test.Hspec++import qualified HaskellWorks.Data.FingerTree.Gen as G+import qualified Hedgehog.Gen                     as G+import qualified Hedgehog.Range                   as R+import qualified Prelude                          as P++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: redundant bracket"          :: String) #-}++spec :: Spec+spec = do+  it "foldr" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    foldr (:) [] xs === P.foldr (:) [] (toList xs)+  it "foldl" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    foldl (flip (:)) [] xs === P.foldl (flip (:)) [] (toList xs)+  it "(==)" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    (xs == ys) === (toList xs == toList ys)+  it "compare" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    compare xs ys === compare (toList xs) (toList ys)+  it "mappend" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (mappend xs ys) ~== toList xs ++ toList ys+  it "empty" $ require $ property $ do+    toList' (empty :: Seq Int) === Just []+  it "singletone" $ require $ property $ do+    x <- forAll (G.int R.constantBounded)+    toList' (singleton x) ~== [x]+  it "(<|)" $ require $ property $ do+    x  <- forAll (G.int R.constantBounded)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (x <| xs) ~== x : toList xs+  it "(|>)" $ require $ property $ do+    x  <- forAll (G.int R.constantBounded)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (xs |> x) ~== toList xs ++ [x]+  it "(><)" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (xs >< ys) ~== toList xs ++ toList ys+  it "fromList" $ require $ property $ do+    xs <- forAll (G.list (R.linear 0 100) (G.int R.constantBounded))+    toList' (fromList xs) ~== xs+  it "null" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    null xs === P.null (toList xs)+  it "viewl" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    case viewl xs of+      EmptyL    -> P.null (toList xs) === True+      x :< xs'  -> do+        valid xs' === True+        toList xs === x : toList xs'+  it "viewr" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    case viewr xs of+      EmptyR    -> P.null (toList xs) === True+      xs' :> x  -> do+        valid xs' === True+        toList xs === toList xs' ++ [x]+  it "split" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toListPair' (split p xs) ~== P.splitAt n (toList xs)+  it "takeUntil" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (takeUntil p xs) ~== P.take n (toList xs)+  it "dropUntil" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (dropUntil p xs) ~== P.drop n (toList xs)+  it "reverse" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (reverse xs) ~== P.reverse (toList xs)+  it "fmap" $ require $ property $ do+    let f = Just+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (fmap' f xs) ~== map f (toList xs)+  it "fmapWithPos" $ require $ property $ do+    let f = (,)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    let xs_list = toList xs+    toList' (fmapWithPos f xs) ~== zipWith f (inits xs_list) xs_list+  it "traverse" $ require $ property $ do+    let f x = do+          n <- step+          return (n, x)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (evalM (traverse' f xs)) ~== evalM (traverse f (toList xs))+  it "traverseWithPos" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    let f xs y = do+          n <- step+          return (xs, n, y)+    let xs_list = toList xs+    toList' (evalM (traverseWithPos f xs)) ~== evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))++infix 4 ~==++(~==) :: (Show a, Eq a) => Maybe a -> a -> PropertyT IO ()+(~==) = maybe (const failure) (===)++newtype M a = M (Int -> (Int, a))++runM :: M a -> Int -> (Int, a)+runM (M m) = m++evalM :: M a -> a+evalM m = snd (runM m 0)++instance Monad M where+    return x = M $ \ n -> (n, x)+    M u >>= f = M $ \ m -> let (n, x) = u m in runM (f x) n++instance Functor M where+    fmap f (M u) = M $ \ m -> let (n, x) = u m in (n, f x)++instance Applicative M where+    pure = return+    (<*>) = ap++step :: M Int+step = M $ \ n -> (n+1, n)++toListPair' ::+    (Eq a, Measured [a] a, Valid a, Eq b, Measured [b] b, Valid b) =>+        (Seq a, Seq b) -> Maybe ([a], [b])+toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys++toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]+toList' xs+  | valid xs = Just (toList xs)+  | otherwise = Nothing++class Valid a where+  valid :: a -> Bool++instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where+    valid Empty = True+    valid (Single x) = valid x+    valid (Deep s pr m sf) =+        s == measure pr `mappend` measure m `mappend` measure sf &&+        valid pr && valid m && valid sf++instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where+    valid node = measure node == foldMap measure node && all valid node++instance Valid a => Valid (Digit a) where+    valid = all valid++instance Valid Int where+    valid = const True++instance Valid (a,b) where+    valid = const True++instance Valid (a,b,c) where+    valid = const True++instance Valid (Maybe a) where+    valid = const True++instance Valid [a] where+    valid = const True++------------------------------------------------------------------------+-- Use list of elements as the measure+------------------------------------------------------------------------++type Seq a = FingerTree [a] a++instance Measured [Int] Int where+    measure x = [x]++instance Measured [Maybe a] (Maybe a) where+    measure x = [x]++instance Measured [(a, b)] (a, b) where+    measure x = [x]++instance Measured [(a, b, c)] (a, b, c) where+    measure x = [x]