packages feed

binding-core 0.2 → 0.2.1

raw patch · 3 files changed

+325/−1 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

binding-core.cabal view
@@ -1,5 +1,5 @@ name:           binding-core
-version:        0.2
+version:        0.2.1
 cabal-version:  >= 1.9.2
 license:        BSD3
 license-file:   LICENSE
+ tests/HUnit.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TupleSections #-}
+import Test.HUnit
+
+import Control.Monad
+import Data.IORef
+import System.Exit
+import System.Random
+
+import Data.Binding.List as B
+import Prelude as P
+
+-- Change these to exercise different variable and data types
+type V = IORef
+type A = Int
+
+-- *** Test pure helpers ***
+
+-- | Generate a list for testing.
+-- Many operations are expected to fail on lists of less than 2 elements.
+list' :: IO ([A], Int)
+list' = do size <- randomRIO (2,100)
+           list <- replicateM size randomIO
+           return (list, size)
+
+testRemove' :: Assertion
+testRemove' = do (list, size) <- list'
+                 pos <- randomRIO (0, size-2)
+                 let actual = remove' list pos
+                 assertEqual "List hasn't shrunk correctly" (size-1) (P.length actual)
+                 assertEqual "Head of list incorrect" (take pos list) (take pos actual)
+                 assertEqual "Tail of list incorrect" (drop (pos+1) list) (drop pos actual)
+
+testRemoveLast' :: Assertion
+testRemoveLast' = do (list, size) <- list'
+                     let actual = remove' list (size-1)
+                     assertEqual "List hasn't shrunk correctly" (size-1) (P.length actual)
+                     assertEqual "List is incorrect" (take (size-1) list) actual
+
+testInsert' :: Assertion
+testInsert' = do (list, size) <- list'
+                 pos <- randomRIO (0, size-1)
+                 new <- randomIO
+                 let actual = insert' list pos new
+                 assertEqual "List hasn't shrunk correctly" (size+1) (P.length actual)
+                 assertEqual "Head of list incorrect" (take pos list) (take pos actual)
+                 assertEqual "Element not inserted" new (actual !! pos)
+                 assertEqual "Tail of list incorrect" (drop pos list) (drop (pos+1) actual)
+
+--- *** Test monadic functions ***
+
+testSource :: Assertion
+testSource = do --bind a source
+                expected <- randomIO
+                source <- newVar expected :: IO (Source V A)
+                target <- randomIO >>= newVar :: IO (Source V A)
+                bind source id target writeVar
+                actual <- readVar target
+                assertEqual "Initial Bind" expected actual
+                --change its value
+                expected <- randomIO
+                writeVar source expected
+                actual <- readVar target
+                assertEqual "Value Changed" expected actual
+
+-- | Generate a 'BindingList' for testing.
+list :: IO ([A], Int, BindingList V A)
+list = do (list, size) <- list'
+          liftM (list, size,) (toBindingList list)
+
+-- | Assert that a 'BindingList' holds the expected list.
+assertList :: [A] -> BindingList V A -> Assertion
+assertList list bl = fromBindingList bl >>= (list @=?)
+
+-- | Assert that a 'BindingList' holds the expected list.
+assertPos :: Int -> BindingList V A -> Int -> Assertion
+assertPos expected bl reported = do pos <- position bl
+                                    assertEqual "Wrong positon" expected pos
+                                    assertEqual "Wrong positon reported" pos reported
+
+testList :: Assertion
+testList = do (expected, _, bl) <- list
+              assertList expected bl
+
+testLength :: Assertion
+testLength = do (_, expected, bl) <- list
+                B.length bl >>= (expected @=?)
+
+testSeek :: Assertion
+testSeek = do (list, size, bl) <- list
+              pos <- randomRIO (0,size-1)
+              seek bl pos >>= assertPos pos bl
+              actual <- readVar bl
+              list !! pos @=? actual
+
+testSeekBy :: Assertion
+testSeekBy = do (_, size, bl) <- list
+                init <- randomRIO (0, size-1)
+                offset <- randomRIO (-init, size-init-1)
+                let expected = init + offset
+                seek bl init
+                actual <- seekBy (offset+) bl
+                --give a more detailed error message than assertPos
+                assertEqual ("Seek from " ++ show init ++ " by " ++ show offset) expected actual
+                assertPos expected bl actual
+
+testNext :: Assertion
+testNext = do (_, size, bl) <- list
+              init <- randomRIO (0, size-2)
+              seek bl init
+              B.next bl >>= assertPos (init+1) bl
+
+testPrev :: Assertion
+testPrev = do (_, size, bl) <- list
+              init <- randomRIO (1, size-1)
+              seek bl init
+              prev bl >>= assertPos (init-1) bl
+
+testRemove :: Assertion
+testRemove = do (list, size, bl) <- list
+                pos <- randomRIO (0, size-2)
+                seek bl pos
+                remove bl >>= assertPos pos bl
+                assertList (remove' list pos) bl
+
+testRemoveLast :: Assertion
+testRemoveLast = do (list, size, bl) <- list
+                    seek bl (size-1)
+                    remove bl >>= assertPos (size-2) bl
+                    assertList (remove' list (size-1)) bl
+
+testInsert :: Assertion
+testInsert = do (list, size, bl) <- list
+                pos <- randomRIO (0, size-1)
+                new <- randomIO
+                seek bl pos
+                let pos' = pos+1
+                insert bl new >>= assertPos pos' bl
+                assertList (insert' list pos' new) bl
+
+main = do Counts _ _ e f <- runTestTT $ TestList
+             ["Source" ~: testSource
+             ,"binding lists" ~: testList
+             ,"length" ~: testLength
+             ,"seek" ~: testSeek
+             ,"seekBy" ~: testSeekBy
+             ,"next" ~: testNext
+             ,"prev" ~: testPrev
+             ,"remove'" ~: testRemove'
+             ,"remove" ~: testRemove
+             ,"remove' last" ~: testRemoveLast'
+             ,"remove last" ~: testRemoveLast
+             ,"insert'" ~: testInsert'
+             ,"insert" ~: testInsert]
+          when (e>0 || f>0) exitFailure
+ tests/QuickCheck.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TupleSections, TemplateHaskell #-}
+import Test.QuickCheck
+import Test.QuickCheck.Modifiers
+import Test.QuickCheck.Monadic
+import Test.QuickCheck.All
+import Test.QuickCheck.Test
+
+import Control.Monad
+import Data.IORef
+import System.Exit
+
+import Data.Binding.List as B
+import Prelude as P
+
+-- Change these to exercise different variable and data types
+type V = IORef
+type A = Char
+
+-- *** Functions to generate lists and pointers ***
+
+-- | A random list with at least two elements.
+newtype List = List [A] deriving Show
+
+instance Arbitrary List where
+    arbitrary = do a <- arbitrary
+                   b <- arbitrary
+                   c <- arbitrary
+                   return $ List (a:b:c)
+
+    shrink (List [a,b]) = [List [a',b'] | a' <- shrink a, b' <- shrink a]
+    shrink (List xs) = map List $ shrink xs
+
+-- | Maps i to a pointer in @xs@.
+anywhere :: Int -> [A] -> Int
+anywhere i xs = let max = P.length xs - 1
+                in if max == 0 then 0 else i `mod` max
+
+-- | Anywhere in the list except the last element.
+notLast :: Int -> [A] -> Int
+notLast i = anywhere i . tail
+
+-- *** Test pure functions ***
+
+prop_remove' :: [A] -> Int -> Bool
+prop_remove' xs i = let pos = anywhere i xs
+                        actual = remove' xs pos
+                    in P.length actual == P.length xs - 1
+                    && take pos actual == take pos xs
+                    && drop (pos+1) xs == drop pos actual
+
+prop_removeLast' :: [A] -> Bool
+prop_removeLast' xs = let pos = P.length xs - 1
+                          actual = remove' xs pos
+                      in P.length actual == pos
+                      && actual == take pos xs
+
+prop_insert' :: [A] -> Int -> A -> Bool
+prop_insert' xs i x = let pos = anywhere i xs
+                          actual = insert' xs pos x
+                      in P.length actual == P.length xs + 1
+                      && take pos actual == take pos xs
+                      && actual !! pos == x
+                      && drop pos actual == drop (pos+1) xs
+
+-- *** Tests in 'IO'. They are converted to 'Property's with 'monadicIO'. ***
+
+-- | Create a 'BindingList', and 'seek' to @pos@.
+list :: [A] -> Int -> IO (BindingList V A)
+list xs pos = do bl <- toBindingList xs
+                 seek bl pos
+                 return bl
+
+testSource :: (A,A,A) -> IO (A,A)
+testSource (a,b,c) = do --bind a source
+                     source <- newVar a :: IO (Source V A)
+                     target <- newVar c :: IO (Source V A)
+                     bind source id target writeVar
+                     x <- readVar target
+                     --change its value
+                     writeVar source b
+                     y <- readVar target
+                     return (x,y)
+
+testSeek :: [A] -> Int -> IO (Int, A)
+testSeek xs pos = do bl <- toBindingList xs :: IO (BindingList V A)
+                     liftM2 (,) (seek bl pos) (readVar bl)
+
+testPosition :: [A] -> Int -> IO Int
+testPosition xs init = list xs init >>= position
+
+testSeekBy :: [A] -> Int -> Int -> IO (Int, A)
+testSeekBy xs init offset = do bl <- list xs init
+                               liftM2 (,) (seekBy (offset+) bl) (readVar bl)
+
+testNext :: [A] -> Int -> IO (Int, A)
+testNext xs init = do bl <- list xs init
+                      liftM2 (,) (B.next bl) (readVar bl)
+
+testPrev :: [A] -> Int -> IO (Int, A)
+testPrev xs init = do bl <- list xs init
+                      liftM2 (,) (prev bl) (readVar bl)
+
+testRemove :: [A] -> Int -> IO (Int, [A])
+testRemove xs pos = do bl <- list xs pos
+                       liftM2 (,) (remove bl) (fromBindingList bl)
+
+testInsert :: [A] -> Int -> A -> IO (Int, [A])
+testInsert xs pos new = do bl <- list xs pos
+                           liftM2 (,) (insert bl new) (fromBindingList bl)
+
+-- *** QuickCheck 'Property's for Monadic actions. ***
+
+prop_Source :: (A,A,A) -> Property
+prop_Source (a,b,c) = monadicIO $ do
+    (x,y) <- run $ testSource (a,b,c)
+    assert (x==a && y==b)
+
+prop_Length :: NonEmptyList A -> Property
+prop_Length (NonEmpty xs) = monadicIO $ do
+    l <- run $ (toBindingList xs :: IO (BindingList V A)) >>= B.length
+    assert (l == P.length xs)
+
+prop_seek :: NonEmptyList A -> Int -> Property
+prop_seek (NonEmpty xs) i = let pos = anywhere i xs in monadicIO $ do
+    (new, x) <- run $ testSeek xs pos
+    assert (new == pos && x == xs !! pos)
+
+prop_position :: NonEmptyList A -> Int -> Property
+prop_position (NonEmpty xs) i = let pos = anywhere i xs in monadicIO $ do
+    new <- run $ testPosition xs pos
+    assert (new == pos)
+
+prop_seekBy :: List -> Int -> Int -> Property
+prop_seekBy (List xs) a b = let size = P.length xs
+                                init = anywhere a xs
+                                offset = anywhere b xs - init
+                            in monadicIO $ do
+    (new, x) <- run $ testSeekBy xs init offset
+    assert (new == init + offset && x == xs !! new)
+
+prop_next :: List -> Int -> Property
+prop_next (List xs) i = let pos = notLast i xs in monadicIO $ do
+    (new, x) <- run $ testNext xs pos
+    assert (new == pos + 1 && x == xs !! new)
+
+prop_prev :: List -> Int -> Property
+prop_prev (List xs) i = let pos = anywhere i xs + 1 in monadicIO $ do
+    (new, x) <- run $ testPrev xs pos
+    assert (new == pos - 1 && x == xs !! new)
+
+prop_remove :: List -> Int -> Property
+prop_remove (List xs) i = let pos = notLast i xs in monadicIO $ do
+    (pos',ys) <- run $ testRemove xs pos
+    assert (ys == remove' xs pos && pos' == pos)
+
+prop_removeLast :: List -> Property
+prop_removeLast (List xs) = let pos = P.length xs - 1 in monadicIO $ do
+    (pos',ys) <- run $ testRemove xs pos
+    assert (ys == remove' xs pos && pos' == pos -1)
+
+prop_insert :: List -> Int -> A -> Property
+prop_insert (List xs) i x = let pos = anywhere i xs
+                                new = pos + 1
+                            in monadicIO $ do
+    (pos',ys) <- run $ testInsert xs pos x
+    assert (ys == insert' xs new x && pos' == new)
+
+-- | Test the 'Property's.
+main = do passed <- $quickCheckAll
+          unless passed exitFailure