diff --git a/hw-fingertree-strict.cabal b/hw-fingertree-strict.cabal --- a/hw-fingertree-strict.cabal +++ b/hw-fingertree-strict.cabal @@ -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. - + * Ralf Hinze and Ross Paterson, + \"Finger trees: a simple general-purpose data structure\", + /Journal of Functional Programming/ 16:2 (2006) pp 197-217. + . 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 diff --git a/src/HaskellWorks/Data/FingerTree/Strict.hs b/src/HaskellWorks/Data/FingerTree/Strict.hs --- a/src/HaskellWorks/Data/FingerTree/Strict.hs +++ b/src/HaskellWorks/Data/FingerTree/Strict.hs @@ -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) diff --git a/src/HaskellWorks/Data/IntervalMap/Strict.hs b/src/HaskellWorks/Data/IntervalMap/Strict.hs --- a/src/HaskellWorks/Data/IntervalMap/Strict.hs +++ b/src/HaskellWorks/Data/IntervalMap/Strict.hs @@ -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 diff --git a/src/HaskellWorks/Data/PriorityQueue/Strict.hs b/src/HaskellWorks/Data/PriorityQueue/Strict.hs --- a/src/HaskellWorks/Data/PriorityQueue/Strict.hs +++ b/src/HaskellWorks/Data/PriorityQueue/Strict.hs @@ -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 diff --git a/test/HaskellWorks/Data/FingerTree/Strict/Gen.hs b/test/HaskellWorks/Data/FingerTree/Strict/Gen.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/FingerTree/Strict/Gen.hs @@ -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] diff --git a/test/HaskellWorks/Data/FingerTree/StrictSpec.hs b/test/HaskellWorks/Data/FingerTree/StrictSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/FingerTree/StrictSpec.hs @@ -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]