packages feed

hw-fingertree-strict 0.1.0.1 → 0.1.0.2

raw patch · 6 files changed

+359/−66 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

hw-fingertree-strict.cabal view
@@ -1,71 +1,89 @@-name:                   hw-fingertree-strict-version:                0.1.0.1--- synopsis:--- description:-homepage:               https://github.com/githubuser/hw-fingertree-strict#readme-license:                BSD3-license-file:           LICENSE-author:                 John Ky-maintainer:             newhoggy@gmail.com-copyright:              2017 John Ky; 2006 Ross Paterson, Ralf Hinze-category:               Data Structures-Synopsis:       Generic strict finger-tree structure-Description:-                A general sequence representation with arbitrary+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: cf96e753aa89a6ce71fe493132b754969cc657812d4d88482f673fee7fe3a96c++name:           hw-fingertree-strict+version:        0.1.0.2+synopsis:       Generic strict finger-tree structure+description:    A general sequence representation with arbitrary                 annotations, for use as a base for implementations of                 various collection types, with examples, as described                 in section 4 of                 .-                 * Ralf Hinze and Ross Paterson,-                   \"Finger trees: a simple general-purpose data structure\",-                   /Journal of Functional Programming/ 16:2 (2006) pp 197-217.-                   <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+                * Ralf Hinze and Ross Paterson,+                \"Finger trees: a simple general-purpose data structure\",+                /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+                <http://staff.city.ac.uk/~ross/papers/FingerTree.html>                 .                 For a tuned sequence type, see @Data.Sequence@ in the                 @containers@ package, which is a specialization of                 this structure.-build-type:             Simple-extra-source-files:     README.md-cabal-version:          >=1.10+category:       Data Structures+homepage:       https://github.com/haskell-works/hw-fingertree-strict#readme+bug-reports:    https://github.com/haskell-works/hw-fingertree-strict/issues+author:         John Ky+maintainer:     newhoggy@gmail.com+copyright:      2017 John Ky; 2006 Ross Paterson,+                Ralf Hinze+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10 +extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/haskell-works/hw-fingertree-strict+ library-  hs-source-dirs:       src-  exposed-modules:      HaskellWorks.Data.FingerTree.Strict-                      , HaskellWorks.Data.IntervalMap.Strict-                      , HaskellWorks.Data.Item.Strict-                      , HaskellWorks.Data.PriorityQueue.Strict-                      , HaskellWorks.Data.SegmentMap.Strict-                      , HaskellWorks.Data.SegmentSet.Strict-                      , HaskellWorks.Data.Segment.Strict-  build-depends:        base >= 4.7 && < 5-  default-language:     Haskell2010-  if !impl(ghc >= 8.0)-    build-depends: semigroups == 0.18.*+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+  if !(impl(ghc >=8.0))+    build-depends:+        semigroups ==0.18.*+  exposed-modules:+      HaskellWorks.Data.FingerTree.Strict+      HaskellWorks.Data.IntervalMap.Strict+      HaskellWorks.Data.Item.Strict+      HaskellWorks.Data.PriorityQueue.Strict+      HaskellWorks.Data.SegmentMap.Strict+      HaskellWorks.Data.SegmentSet.Strict+      HaskellWorks.Data.Segment.Strict+  other-modules:+      Paths_hw_fingertree_strict+  default-language: Haskell2010  test-suite hw-fingertree-strict-test   type: exitcode-stdio-1.0-  default-language: Haskell2010-  other-modules:        HaskellWorks.Data.Gen-                      , HaskellWorks.Data.SegmentMap.StrictSpec-                      , HaskellWorks.Data.SegmentSet.StrictSpec-                      , HaskellWorks.Data.SegmentSet.Naive-                      , HaskellWorks.Data.SegmentSet.NaiveSpec-  hs-source-dirs:  test-  main-is:         Spec.hs+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N   cpp-options: -DTESTING-  build-depends:        base >= 4.2 && < 6-                      , hedgehog-                      , hspec-                      , HUnit-                      , hw-fingertree-strict-                      , hw-hspec-hedgehog-                      , QuickCheck-                      , test-framework-                      , test-framework-hunit-                      , test-framework-quickcheck2-  ghc-options:          -threaded -rtsopts -with-rtsopts=-N-  default-language:     Haskell2010--source-repository head-  type:     git-  location: https://github.com/haskell-works/hw-fingertree-strict+  build-depends:+      HUnit+    , QuickCheck+    , base >=4.2 && <6+    , hedgehog+    , hspec+    , hw-fingertree-strict+    , hw-hspec-hedgehog+    , test-framework+    , test-framework-hunit+    , test-framework-quickcheck2+  other-modules:+      HaskellWorks.Data.FingerTree.Strict.Gen+      HaskellWorks.Data.FingerTree.StrictSpec+      HaskellWorks.Data.Gen+      HaskellWorks.Data.SegmentMap.StrictSpec+      HaskellWorks.Data.SegmentSet.Naive+      HaskellWorks.Data.SegmentSet.NaiveSpec+      HaskellWorks.Data.SegmentSet.StrictSpec+      Paths_hw_fingertree_strict+  default-language: Haskell2010
src/HaskellWorks/Data/FingerTree/Strict.hs view
@@ -103,8 +103,9 @@ instance Measured v a => Monoid (FingerTree v a) where   mempty = empty   {-# INLINE mempty #-}-  mappend = (<>)+  mappend = (><)   {-# INLINE mappend #-}+  -- Explicit Digit type (Exercise 1)
src/HaskellWorks/Data/IntervalMap/Strict.hs view
@@ -80,16 +80,20 @@ -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval !(Interval v) !v +appendInterval :: Ord v => IntInterval v -> IntInterval v -> IntInterval v+appendInterval (NoInterval       ) (i                   ) = i+appendInterval (i                ) (NoInterval          ) = i+appendInterval (IntInterval _ hi1) (IntInterval int2 hi2) = IntInterval int2 (max hi1 hi2)+{-# INLINE appendInterval #-}+ instance Ord v => S.Semigroup (IntInterval v) where-  NoInterval        <> i                    = i-  i                 <> NoInterval           = i-  IntInterval _ hi1 <> IntInterval int2 hi2 = IntInterval int2 (max hi1 hi2)+  (<>) = appendInterval   {-# INLINE (<>) #-}  instance Ord v => Monoid (IntInterval v) where   mempty = NoInterval   {-# INLINE mempty #-}-  mappend = (<>)+  mappend = appendInterval   {-# INLINE mappend #-}  instance (Ord v) => Measured (IntInterval v) (Node v a) where
src/HaskellWorks/Data/PriorityQueue/Strict.hs view
@@ -73,16 +73,20 @@  data Prio k v = NoPrio | Prio k v +appendPrio :: Ord k => Prio k v -> Prio k v -> Prio k v+appendPrio x             NoPrio        = x+appendPrio NoPrio        y             = y+appendPrio x@(Prio kx _) y@(Prio ky _) = if kx <= ky then x else y+{-# INLINE appendPrio #-}+ instance Ord k => S.Semigroup (Prio k v) where-  x             <> NoPrio         = x-  NoPrio        <> y              = y-  x@(Prio kx _) <> y@(Prio ky _)  = if kx <= ky then x else y+  (<>) = appendPrio   {-# INLINE (<>) #-}  instance Ord k => Monoid (Prio k v) where     mempty  = NoPrio     {-# INLINE mempty #-}-    mappend = (<>)+    mappend = appendPrio     {-# INLINE mappend #-}  instance Ord k => Measured (Prio k v) (Entry k v) where
+ test/HaskellWorks/Data/FingerTree/Strict/Gen.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}++module HaskellWorks.Data.FingerTree.Strict.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]
+ test/HaskellWorks/Data/FingerTree/StrictSpec.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.FingerTree.StrictSpec (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.Strict.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]