fingertree 0.0.1.1 → 0.1.0.0

raw patch · 5 files changed

+384/−14 lines, 5 filesdep +HUnitdep +QuickCheckdep +test-frameworkdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/FingerTree.hs +29/−10
• Data/IntervalMap/FingerTree.hs +5/−0
• Data/PriorityQueue/FingerTree.hs +2/−2
• fingertree.cabal +14/−2
• tests/ft-properties.hs +334/−0

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.FingerTree@@ -31,7 +31,11 @@ -----------------------------------------------------------------------------  module Data.FingerTree (+#if TESTING+	FingerTree(..), Digit(..), Node(..), deep, node2, node3,+#else 	FingerTree,+#endif 	Measured(..), 	-- * Construction 	empty, singleton,@@ -54,7 +58,6 @@ import Control.Applicative (Applicative(pure, (<*>)), (<$>)) import Data.Monoid import Data.Foldable (Foldable(foldMap), toList)-import Data.Traversable (Traversable(traverse))  infixr 5 >< infixr 5 <|, :<@@ -74,13 +77,14 @@ 	deriving (Eq, Ord, Show, Read)  instance Functor s => Functor (ViewL s) where-	fmap f EmptyL           = EmptyL+	fmap _ EmptyL           = EmptyL 	fmap f (x :< xs)        = f x :< fmap f xs  instance Functor s => Functor (ViewR s) where-	fmap f EmptyR           = EmptyR+	fmap _ EmptyR           = EmptyR 	fmap f (xs :> x)        = fmap f xs :> f x +-- | 'empty' and '><'. instance Measured v a => Monoid (FingerTree v a) where 	mempty = empty 	mappend = (><)@@ -151,11 +155,15 @@ 	= Empty 	| Single a 	| Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)+#if TESTING+	deriving Show+#endif  deep ::  (Measured v a) =>  	 Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf +-- | /O(1)/. The cached measure of a tree. instance (Measured v a) => Measured v (FingerTree v a) where 	measure Empty           =  mempty 	measure (Single x)      =  measure x@@ -167,15 +175,17 @@ 	foldMap f (Deep _ pr m sf) = 		foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf -instance (Measured v a, Eq a) => Eq (FingerTree v a) where+instance Eq a => Eq (FingerTree v a) where 	xs == ys = toList xs == toList ys -instance (Measured v a, Ord a) => Ord (FingerTree v a) where+instance Ord a => Ord (FingerTree v a) where 	compare xs ys = compare (toList xs) (toList ys) -instance (Measured v a, Show a) => Show (FingerTree v a) where+#if !TESTING+instance Show a => Show (FingerTree v a) where 	showsPrec p xs = showParen (p > 10) $ 		showString "fromList " . shows (toList xs)+#endif  -- | Like 'fmap', but with a more constrained type. fmap' :: (Measured v1 a1, Measured v2 a2) =>@@ -350,6 +360,7 @@ consDigit a (One b) = Two a b consDigit a (Two b c) = Three a b c consDigit a (Three b c d) = Four a b c d+consDigit _ (Four _ _ _ _) = illegal_argument "consDigit"  -- | /O(1)/. Add an element to the right end of a sequence. -- Mnemonic: a triangle with the single element at the pointy end.@@ -365,6 +376,7 @@ snocDigit (One a) b = Two a b snocDigit (Two a b) c = Three a b c snocDigit (Three a b c) d = Four a b c d+snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit"  -- | /O(1)/. Is this the empty sequence? null :: (Measured v a) => FingerTree v a -> Bool@@ -390,6 +402,7 @@ lheadDigit (Four a _ _ _) = a  ltailDigit :: Digit a -> Digit a+ltailDigit (One _) = illegal_argument "ltailDigit" ltailDigit (Two _ b) = One b ltailDigit (Three _ b c) = Two b c ltailDigit (Four _ b c d) = Three b c d@@ -413,6 +426,7 @@ rheadDigit (Four _ _ _ d) = d  rtailDigit :: Digit a -> Digit a+rtailDigit (One _) = illegal_argument "rtailDigit" rtailDigit (Two a _) = One a rtailDigit (Three a b _) = Two a b rtailDigit (Four a b c _) = Three a b c@@ -672,7 +686,7 @@ -- point, i.e. that the predicate is /monotonic/. split ::  (Measured v a) =>            (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)-split _p Empty  =  (Empty, Empty)+split _ Empty  =  (Empty, Empty) split p xs   | p (measure xs) =  (l, x <| r)   | otherwise	=  (xs, Empty)@@ -698,7 +712,8 @@  splitTree ::	(Measured v a) =>  		(v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a-splitTree _p _i (Single x) = Split Empty x Empty+splitTree _ _ Empty = illegal_argument "splitTree"+splitTree _ _ (Single x) = Split Empty x Empty splitTree p i (Deep _ pr m sf)   | p vpr	=  let	Split l x r	=  splitDigit p i pr 		   in	Split (maybe Empty digitToTree l) x (deepL r m sf)@@ -740,7 +755,7 @@  splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a -> 		Split (Maybe (Digit a)) a-splitDigit p i (One a) = i `seq` Split Nothing a Nothing+splitDigit _ i (One a) = i `seq` Split Nothing a Nothing splitDigit p i (Two a b)   | p va	= Split Nothing a (Just (One b))   | otherwise	= Split (Just (One a)) b Nothing@@ -783,6 +798,10 @@ reverseDigit f (Two a b) = Two (f b) (f a) reverseDigit f (Three a b c) = Three (f c) (f b) (f a) reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++illegal_argument :: String -> a+illegal_argument name =+	error $ "Logic error: " ++ name ++ " called with illegal argument"  {- $example 

@@ -97,6 +97,11 @@ 	traverse f (IntervalMap t) = 		IntervalMap <$> FT.unsafeTraverse (traverse f) t +-- | 'empty' and 'union'.+instance (Ord v) => Monoid (IntervalMap v a) where+	mempty = empty+	mappend = union+ -- | /O(1)/.  The empty interval map. empty :: (Ord v) => IntervalMap v a empty = IntervalMap FT.empty

@@ -136,7 +136,7 @@ null :: Ord k => PQueue k v -> Bool null (PQueue q) = FT.null q --- | /O(1)/ (/O(log(n))/ for the reduced queue).+-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the value associated with the -- minimal priority together with the rest of the priority queue. --@@ -147,7 +147,7 @@ minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v) minView q = fmap (snd *** id) (minViewWithKey q) --- | /O(1)/ (/O(log(n))/ for the reduced queue).+-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the minimal (priority, value) -- pair together with the rest of the priority queue. --

@@ -1,6 +1,6 @@ Name:           fingertree-Version:        0.0.1.1-Cabal-Version:  >= 1.6+Version:        0.1.0.0+Cabal-Version:  >= 1.8 Copyright:      (c) 2006 Ross Paterson, Ralf Hinze License:        BSD3 License-File:   LICENSE@@ -37,3 +37,15 @@                 Data.FingerTree                 Data.IntervalMap.FingerTree                 Data.PriorityQueue.FingerTree++Test-suite ft-properties+  type: exitcode-stdio-1.0+  main-is: tests/ft-properties.hs+  cpp-options: -DTESTING+  build-depends:+                base >= 4.2 && < 6,+                HUnit,+                QuickCheck,+                test-framework,+                test-framework-hunit,+                test-framework-quickcheck2

@@ -0,0 +1,334 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- QuickCheck properties for Data.FingerTree++module Main where++import Data.FingerTree    -- needs to be compiled with -DTESTING for use here++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (Assertion, (@?=))+import Test.QuickCheck hiding ((><))+import Test.QuickCheck.Poly++import Prelude hiding (null, reverse, foldl, foldl1, foldr, foldr1, all)+import qualified Prelude++import Control.Applicative (Applicative(..))+import Control.Monad (ap)+import Data.Foldable (Foldable(..), toList, all)+import Data.Functor ((<$>))+import Data.Traversable (traverse)+import Data.List (inits)+import Data.Monoid (Monoid(..))++main :: IO ()+main = defaultMainWithOpts+    [ testProperty "foldr" prop_foldr+    , testProperty "foldl" prop_foldl+    , testProperty "(==)" prop_equals+    , testProperty "compare" prop_compare+    , testProperty "mappend" prop_mappend+    , testCase "empty" test_empty+    , testProperty "singleton" prop_singleton+    , testProperty "(<|)" prop_cons+    , testProperty "(|>)" prop_snoc+    , testProperty "(><)" prop_append+    , testProperty "fromList" prop_fromList+    , testProperty "null" prop_null+    , testProperty "viewl" prop_viewl+    , testProperty "viewr" prop_viewr+    , testProperty "split" prop_split+    , testProperty "takeUntil" prop_takeUntil+    , testProperty "dropUntil" prop_dropUntil+    , testProperty "reverse" prop_reverse+    , testProperty "fmap'" prop_fmap'+    -- , testProperty "fmapWithPos" prop_fmapWithPos -- (slow)+    , testProperty "traverse'" prop_traverse'+    -- , testProperty "traverseWithPos" prop_traverseWithPos -- (slow)+    ] runner_opts+  where+    runner_opts = mempty { ropt_test_options = Just test_opts }+    test_opts = mempty {+          topt_maximum_generated_tests = Just 500+        , topt_maximum_unsuitable_generated_tests = Just 500+        }++{--------------------------------------------------------------------+  The general plan is to compare each function with a list equivalent.+  Each operation should produce a valid tree representing the same+  sequence as produced by its list counterpart on corresponding inputs.+  (The list versions are often lazier, but these properties ignore+  strictness.)+--------------------------------------------------------------------}++-- utilities for partial conversions++infix 4 ~=++(~=) :: Eq a => Maybe a -> a -> Bool+(~=) = maybe (const False) (==)++-- Partial conversion of an output sequence to a list.+toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]+toList' xs+  | valid xs = Just (toList xs)+  | otherwise = Nothing++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++-- instances++prop_foldr :: Seq A -> Bool+prop_foldr xs =+    foldr f z xs == Prelude.foldr f z (toList xs)+  where+    f = (:)+    z = []++prop_foldl :: Seq A -> Bool+prop_foldl xs =+    foldl f z xs == Prelude.foldl f z (toList xs)+  where+    f = flip (:)+    z = []++prop_equals :: Seq OrdA -> Seq OrdA -> Bool+prop_equals xs ys =+    (xs == ys) == (toList xs == toList ys)++prop_compare :: Seq OrdA -> Seq OrdA -> Bool+prop_compare xs ys =+    compare xs ys == compare (toList xs) (toList ys)++prop_mappend :: Seq A -> Seq A -> Bool+prop_mappend xs ys =+    toList' (mappend xs ys) ~= toList xs ++ toList ys++-- * Construction++test_empty :: Assertion+test_empty =+    toList' (empty :: Seq A) @?= Just []++prop_singleton :: A -> Bool+prop_singleton x =+    toList' (singleton x) ~= [x]++prop_cons :: A -> Seq A -> Bool+prop_cons x xs =+    toList' (x <| xs) ~= x : toList xs++prop_snoc :: Seq A -> A -> Bool+prop_snoc xs x =+    toList' (xs |> x) ~= toList xs ++ [x]++prop_append :: Seq A -> Seq A -> Bool+prop_append xs ys =+    toList' (xs >< ys) ~= toList xs ++ toList ys++prop_fromList :: [A] -> Bool+prop_fromList xs =+    toList' (fromList xs) ~= xs++-- * Deconstruction++prop_null :: Seq A -> Bool+prop_null xs =+    null xs == Prelude.null (toList xs)++prop_viewl :: Seq A -> Bool+prop_viewl xs =+    case viewl xs of+    EmptyL ->   Prelude.null (toList xs)+    x :< xs' -> valid xs' && toList xs == x : toList xs'++prop_viewr :: Seq A -> Bool+prop_viewr xs =+    case viewr xs of+    EmptyR ->   Prelude.null (toList xs)+    xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]++prop_split :: Int -> Seq A -> Bool+prop_split n xs =+    toListPair' (split p xs) ~= Prelude.splitAt n (toList xs)+  where p ys = Prelude.length ys > n++prop_takeUntil :: Int -> Seq A -> Bool+prop_takeUntil n xs =+    toList' (takeUntil p xs) ~= Prelude.take n (toList xs)+  where p ys = Prelude.length ys > n++prop_dropUntil :: Int -> Seq A -> Bool+prop_dropUntil n xs =+    toList' (dropUntil p xs) ~= Prelude.drop n (toList xs)+  where p ys = Prelude.length ys > n++-- * Transformation++prop_reverse :: Seq A -> Bool+prop_reverse xs =+    toList' (reverse xs) ~= Prelude.reverse (toList xs)++prop_fmap' :: Seq A -> Bool+prop_fmap' xs =+    toList' (fmap' f xs) ~= map f (toList xs)+  where f = Just++prop_fmapWithPos :: Seq A -> Bool+prop_fmapWithPos xs =+    toList' (fmapWithPos f xs) ~= zipWith f (inits xs_list) xs_list+  where f = (,)+	xs_list = toList xs++prop_traverse' :: Seq A -> Bool+prop_traverse' xs =+    toList' (evalM (traverse' f xs)) ~= evalM (traverse f (toList xs))+  where f x = do+		n <- step+		return (n, x)++prop_traverseWithPos :: Seq A -> Bool+prop_traverseWithPos xs =+    toList' (evalM (traverseWithPos f xs)) ~= evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))+  where f xs y = do+		n <- step+		return (xs, n, y)+	xs_list = toList xs++{- untested:+traverseWithPos+-}++------------------------------------------------------------------------+-- QuickCheck+------------------------------------------------------------------------++instance (Arbitrary a, Measured v a) => Arbitrary (FingerTree v a) where+	arbitrary = sized arb+	  where+		arb :: (Arbitrary a, Measured v a) => Int -> Gen (FingerTree v a)+		arb 0 = return Empty+		arb 1 = Single <$> arbitrary+		arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary++	shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]+	shrink (Deep _ pr m sf) =+		[deep pr' m sf | pr' <- shrink pr] +++		[deep pr m' sf | m' <- shrink m] +++		[deep pr m sf' | sf' <- shrink sf]+	shrink (Single x) = map Single (shrink x)+	shrink Empty = []++instance (Arbitrary a, Measured v a) => Arbitrary (Node v a) where+	arbitrary = oneof [+		node2 <$> arbitrary <*> arbitrary,+		node3 <$> arbitrary <*> arbitrary <*> arbitrary]++	shrink (Node2 _ a b) =+		[node2 a' b | a' <- shrink a] +++		[node2 a b' | b' <- shrink b]+	shrink (Node3 _ a b c) =+		[node2 a b, node2 a c, node2 b c] +++		[node3 a' b c | a' <- shrink a] +++		[node3 a b' c | b' <- shrink b] +++		[node3 a b c' | c' <- shrink c]++instance Arbitrary a => Arbitrary (Digit a) where+	arbitrary = oneof [+		One <$> arbitrary,+		Two <$> arbitrary <*> arbitrary,+		Three <$> arbitrary <*> arbitrary <*> arbitrary,+		Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]++	shrink (One a) = map One (shrink a)+	shrink (Two a b) = [One a, One b]+	shrink (Three a b c) = [Two a b, Two a c, Two b c]+	shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]++------------------------------------------------------------------------+-- Valid trees+------------------------------------------------------------------------++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 A 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 [A] A where+    measure x = [x]++instance Measured [OrdA] OrdA 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]++------------------------------------------------------------------------+-- Simple counting monad+------------------------------------------------------------------------++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)