diff --git a/dist/build/sequence-testsStub/sequence-testsStub-tmp/sequence-testsStub.hs b/dist/build/sequence-testsStub/sequence-testsStub-tmp/sequence-testsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/sequence-testsStub/sequence-testsStub-tmp/sequence-testsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import TestSuite.Sequence ( tests ) +main :: IO () +main = stubMain tests diff --git a/incremental-computing.cabal b/incremental-computing.cabal --- a/incremental-computing.cabal +++ b/incremental-computing.cabal @@ -1,5 +1,5 @@ Name: incremental-computing -Version: 0.0.0.0 +Version: 0.0.1.0 Cabal-Version: >= 1.16 Build-Type: Simple License: BSD3 @@ -9,11 +9,11 @@ Maintainer: wolfgang@cs.ioc.ee Stability: provisional Homepage: http://darcs.wolfgang.jeltsch.info/haskell/incremental-computing -Package-URL: http://hackage.haskell.org/packages/archive/incremental-computing/0.0.0.0/incremental-computing-0.0.0.0.tar.gz +Package-URL: http://hackage.haskell.org/packages/archive/incremental-computing/0.0.1.0/incremental-computing-0.0.1.0.tar.gz Synopsis: Incremental computing Description: This package is about incremental computing. Category: Data -Tested-With: GHC == 7.8.3 +Tested-With: GHC == 8.0.1 Source-Repository head @@ -24,16 +24,16 @@ Type: darcs Location: http://darcs.wolfgang.jeltsch.info/haskell/incremental-computing/main - Tag: incremental-computing-0.0.0.0 + Tag: incremental-computing-0.0.1.0 Library Build-Depends: base >= 3.0 && < 5, containers >= 0.1 && < 0.6, - dlist >= 0.7 && < 0.8, + dlist >= 0.7 && < 0.9, fingertree >= 0.1 && < 0.2, - order-maintenance >= 0.0 && < 0.1, - transformers >= 0.3 && < 0.5 + order-maintenance >= 0.1 && < 0.2, + transformers >= 0.3 && < 0.6 Default-Language: Haskell2010 @@ -44,10 +44,6 @@ TypeFamilies TypeOperators - if impl(ghc >= 7.8) { - Default-Extensions: AutoDeriveTypeable - } - Exposed-Modules: Data.Incremental Data.Incremental.Sequence Data.Incremental.Tuple @@ -59,12 +55,12 @@ Type: detailed-0.9 - Build-Depends: base >= 3.0 && < 5, - Cabal >= 1.16 && < 2, - cabal-test-quickcheck >= 0.1 && < 0.2, - containers >= 0.1 && < 0.6, - QuickCheck >= 2.6 && < 3, - incremental-computing == 0.0.0.0 + Build-Depends: base >= 3.0 && < 5, + Cabal >= 1.16 && < 2, + cabal-test-quickcheck >= 0.1 && < 0.2, + containers >= 0.1 && < 0.6, + QuickCheck >= 2.8.2 && < 3, + incremental-computing == 0.0.1.0 Default-Language: Haskell2010 @@ -79,5 +75,31 @@ Test-Module: TestSuite.Sequence Other-Modules: TestSuite + Utilities - HS-Source-Dirs: src/test-suites + HS-Source-Dirs: src/tools + +Benchmark benchmark + + Type: exitcode-stdio-1.0 + + Build-Depends: base >= 3.0 && < 5, + containers >= 0.1 && < 0.6, + deepseq >= 1.3 && < 1.5, + QuickCheck >= 2.8.2 && < 3, + incremental-computing == 0.0.1.0 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + TypeFamilies + TypeOperators + + Other-Extensions: UndecidableInstances + + Main-Is: Benchmark/Sequence.hs + + Other-Modules: Benchmark + Utilities + + HS-Source-Dirs: src/tools diff --git a/src/library/Data/Incremental.hs b/src/library/Data/Incremental.hs --- a/src/library/Data/Incremental.hs +++ b/src/library/Data/Incremental.hs @@ -14,6 +14,7 @@ simpleTrans, stateTrans, + stateTrans', stTrans, trans, @@ -131,6 +132,30 @@ return change' return (val', stProp)) +{-FIXME: + Say in the documentation that stateTrans' is state-strict in the sense that + reduction of the initial target value and any target change will result in + reduction of the state. Point out that reduction is only to WHNF, so that + the initializer and propagator have to make sure that WHNF reduction + triggers more reduction (for example, by using a data type with strict + fields) if this is desired. +-} +stateTrans' :: (Value p -> (Value q, s)) -> (p -> s -> (q, s)) -> Trans p q +stateTrans' init prop = stateTrans init' prop' where + + init' val = (initState `seq` val', initState) where + + (val', initState) = init val + + prop' change oldState = (newState `seq` change', newState) where + + (change', newState) = prop change oldState + +{-FIXME: + Say in the documentation that it is the resposibility of the user of stTrans + to make sure that reductions of the initial target and target changes + trigger evaluation of any parts of the state for which this is desired. +-} stTrans :: (forall s . TransProc (ST s) p q) -> Trans p q stTrans transProc = trans (\ cont -> runST (cont transProc)) @@ -151,14 +176,18 @@ lazy. If it is strict, the constructed transformation trans will (probably) have the following properties: - • Reducing any expression runTrans trans valAndChanges to WHNF results in - the initialization being run and the constructed propagator being run on - all the changes. + • Reducing any expression runTrans trans src to WHNF results in the + initialization being run and the constructed propagator being run on all + the changes. • The expression toSTProc trans is a processor that always yields ⊥ as the output value and constructs propagators that always yield ⊥ as the output change. -} +{-FIXME: + Say in the documentation that what holds for stTrans regarding state + strictness also holds for trans. +-} trans :: (forall r . (forall m . Monad m => TransProc m p q -> m r) -> r) -> Trans p q trans cpsProcAndRun = errorIfStrictMonad `seq` Trans conv where @@ -169,8 +198,7 @@ strictMonadError = error "Data.Incremental: \ \Transformation processor uses strict monad" - conv valAndChanges = cpsProcAndRun $ - \ transProc -> monadicConv transProc valAndChanges + conv src = cpsProcAndRun $ \ transProc -> monadicConv transProc src monadicConv transProc ~(val, changes) = do ~(val', prop) <- transProc val @@ -317,6 +345,21 @@ cellRef' <- newSTRef undefined writeSTRef cellRef (Cell val cellRef') writeSTRef chan cellRef' +{-FIXME: + We had the following implementation of writeChannel temporarily, which was + inspired by the implementation of Control.Concurrent.Chan.writeChan: + + writeChannel :: Channel s a -> a -> ST s () + writeChannel chan val = do + cellRef' <- newSTRef undefined + mask_ $ do + cellRef <- readSTRef chan + writeSTRef cellRef (Cell val cellRef') + writeSTRef chan cellRef' + + However, this implementation does not work, since mask_ is an IO action, not + an ST action. Do we need to mask asynchronous events? +-} {-FIXME: Is there already an implementation of ST channels? diff --git a/src/library/Data/Incremental/Sequence.hs b/src/library/Data/Incremental/Sequence.hs --- a/src/library/Data/Incremental/Sequence.hs +++ b/src/library/Data/Incremental/Sequence.hs @@ -41,6 +41,14 @@ ) where +{-FIXME: + Starting with GHC 7.10, we probably do not need to hide Prelude.foldl and + import Data.Foldable (at least Data.Foldable.foldl' and + Data.Foldable.toList, because the “Burning Bridges Proposal” has been + implemented (meaning that certain Prelude functions are now the more general + versions from Data.Foldable and Data.Traversable). +-} + -- Prelude import Prelude hiding ( @@ -66,7 +74,7 @@ -- Data import Data.Monoid -import Data.Foldable (foldl, asum, toList) +import Data.Foldable (foldl', asum, toList) import Data.Traversable (traverse) import Data.FingerTree (FingerTree, Measured (measure)) import qualified Data.FingerTree as FingerTree @@ -75,6 +83,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.STRef.Lazy +import Data.Order import Data.MultiChange (MultiChange) import qualified Data.MultiChange as MultiChange import Data.Incremental @@ -94,7 +103,30 @@ refers to the situation before applying this change gets the corresponding identifier that starts with “old”. -} +{-NOTE: + State-strictness policy: + • Reduction of the initial target value causes reduction of the state. + + • In the case of a sequence source, reduction of the part of a target + change that is generated from an atomic change causes reduction of the + state that is current just after this atomic change. + + • In the case of a non-sequence source, reduction of a target change + causes reduction of the state. + + • State data structures are mostly strict, so that reduction of state + causes evaluation of most of the state. + + • Only in the case of gate, the state data structure is not fully strict. + Here, the state contains the current source value lazily. Maybe this + should be changed. + + • In the case of map, state of the element transformation is only reduced + if the corresponding initial target element or target element change + (which is embedded in a ChangeAt change) is reduced. +-} + -- * Changes instance Changeable a => Changeable (Seq a) where @@ -115,12 +147,18 @@ -- * Atomic changes -data AtomicChange a = Insert !Int (Seq a) +data AtomicChange a = Insert !Int !(Seq a) | Delete !Int !Int | Shift !Int !Int !Int | ChangeAt !Int (DefaultChange a) -{-FIXME: - Are these strictness annotations sensible? Should the sequence be strict? +{-NOTE: + Insert is strict in the sequence, since it should be strict in the length of + the sequence, as Delete and Shift are also strict in the length of the + sequence length. Actually, reducing a sequence to WHNF evaluates everything + except the elements, which amounts to evaluating its length. + + ChangeAt is not strict in the element change, since MultiChange is also not + strict in its elements. -} {-NOTE: @@ -197,9 +235,6 @@ len' = (len `max` 0) `min` (totalLen - ix') -noChange :: Changeable a => AtomicChange a -noChange = ChangeAt (-1) mempty - changeLength :: AtomicChange a -> Int -> Int changeLength (Insert _ seq) totalLength = totalLength + Seq.length seq changeLength (Delete _ len) totalLength = totalLength - len @@ -238,7 +273,7 @@ null = fromFunction (== 0) . length length :: Changeable a => Seq a ->> Int -length = MultiChange.composeMap $ stateTrans init prop where +length = MultiChange.composeMap $ stateTrans' init prop where init seq = (len, len) where @@ -253,36 +288,40 @@ -- ** Mapping map :: (Changeable a, Changeable b) => (a ->> b) -> Seq a ->> Seq b -map trans = MultiChange.map $ stTrans (\ seq -> do +map trans = MultiChange.bind $ stTrans (\ seq -> do let elemProc = toSTProc trans let seqInit seq = do procOutputs <- traverse elemProc seq return (fmap fst procOutputs, fmap snd procOutputs) - (seq', elemProps) <- seqInit seq - elemPropsRef <- newSTRef elemProps - let prop (Insert ix seq) = do + (seq', initElemProps) <- seqInit seq + elemPropsRef <- newSTRef initElemProps + let propCore (Insert ix seq) = do (seq', elemProps) <- seqInit seq modifySTRef elemPropsRef (applyInsert ix elemProps) - return (Insert ix seq') - prop (Delete ix len) = do + return (insert ix seq') + propCore (Delete ix len) = do modifySTRef elemPropsRef (applyDelete ix len) - return (Delete ix len) - prop (Shift src len tgt) = do + return (delete ix len) + propCore (Shift src len tgt) = do modifySTRef elemPropsRef (applyShift src len tgt) - return (Shift src len tgt) - prop (ChangeAt ix change) = do + return (shift src len tgt) + propCore (ChangeAt ix change) = do elemProps <- readSTRef elemPropsRef if indexInBounds (Seq.length elemProps) ix then do let elemProp = Seq.index elemProps ix change' <- elemProp change - return (ChangeAt ix change') - else return noChange - return (seq', prop)) + return (changeAt ix change') + else return mempty + let prop change = do + change' <- propCore change + newElemProps <- readSTRef elemPropsRef + return (newElemProps `Prelude.seq` change') + return (initElemProps `Prelude.seq` seq', prop)) map' :: (Changeable a, DefaultChange a ~ PrimitiveChange a, - Changeable b, DefaultChange b ~ PrimitiveChange b) => - (a -> b) -> Seq a ->> Seq b + Changeable b, DefaultChange b ~ PrimitiveChange b) => + (a -> b) -> Seq a ->> Seq b map' fun = MultiChange.map $ simpleTrans (fmap fun) prop where prop (Insert ix seq) = Insert ix (fmap fun seq) @@ -298,8 +337,8 @@ newtype ConcatStateElement = ConcatStateElement Int data ConcatStateMeasure = ConcatStateMeasure { - sourceLength :: Int, - targetLength :: Int + sourceLength :: !Int, + targetLength :: !Int } instance Monoid ConcatStateMeasure where @@ -313,7 +352,7 @@ instance Measured ConcatStateMeasure ConcatStateElement where - measure (ConcatStateElement elLen) = ConcatStateMeasure 1 elLen + measure (ConcatStateElement elemLen) = ConcatStateMeasure 1 elemLen type ConcatState = FingerTree ConcatStateMeasure ConcatStateElement @@ -322,8 +361,10 @@ toList . fmap (ConcatStateElement . Seq.length) +data ChangeAndLength a = ChangeAndLength (DefaultChange (Seq a)) !Int + concat :: Changeable a => Seq (Seq a) ->> Seq a -concat = MultiChange.bind $ stateTrans init prop where +concat = MultiChange.bind $ stateTrans' init prop where init seq = (seqConcat seq, seqToConcatState seq) @@ -367,43 +408,33 @@ (ConcatStateElement elemLen FingerTree.:< rear) = FingerTree.viewl rest - (change', elemLen') = foldl next (mempty, elemLen) change where + ChangeAndLength change' elemLen' = foldl' next init change where - next (curChange, curElemLen) atomic = (curChange', curElemLen') where + init = ChangeAndLength mempty elemLen + next (ChangeAndLength curChange curElemLen) atomic = result where + + result = ChangeAndLength curChange' curElemLen' + normAtomic = normalizeAtomicChange curElemLen atomic shiftedNormAtomic = case normAtomic of Insert elemIx seq - -> Insert (ix' + elemIx) seq + -> insert (ix' + elemIx) seq Delete elemIx curElemLen - -> Delete (ix' + elemIx) curElemLen + -> delete (ix' + elemIx) curElemLen Shift elemSrc curElemLen elemTgt - -> Shift (ix' + elemSrc) curElemLen (ix' + elemTgt) + -> shift (ix' + elemSrc) curElemLen (ix' + elemTgt) ChangeAt elemIx change -> if indexInBounds curElemLen elemIx - then ChangeAt (ix' + elemIx) change - else noChange + then changeAt (ix' + elemIx) change + else mempty - curChange' = MultiChange.singleton shiftedNormAtomic `mappend` - curChange + curChange' = shiftedNormAtomic `mappend` curChange curElemLen' = changeLength normAtomic curElemLen - -- NOTE: Strictness is not perfect. - -- FIXME: One line too wide. state' = front <> (ConcatStateElement elemLen' FingerTree.<| rear) - {-NOTE: - This is a bit fishy. Even if the inner change is illegal, we get a - non-⊥ state. So the state is not always a property of the original - value. If the original value is ⊥, the state might not be ⊥. - However, this should not result in violation of the main property - that changing and then transforming is the same as transforming and - then changing with the propagated change. We would propagate to - non-⊥ changes in the future, but applying these to ⊥ yields ⊥. The - latter might not always be the case, but it is the case for - sequences. - -} splitAndTranslate :: Int -> ConcatState -> (Int, ConcatState, ConcatState) splitAndTranslate ix state = (ix', front, rear) where @@ -422,7 +453,7 @@ gate :: Changeable a => (a ->> Bool) -> a ->> Seq a gate prd = stTrans (\ val -> do valRef <- newSTRef val - ~(accepted, prop) <- toSTProc prd val + (accepted, prop) <- toSTProc prd val acceptedRef <- newSTRef accepted let prop' change = do oldVal <- readSTRef valRef @@ -449,7 +480,7 @@ gate' :: (Changeable a, DefaultChange a ~ PrimitiveChange a) => (a -> Bool) -> a ->> Seq a -gate' prd = stateTrans init prop where +gate' prd = stateTrans' init prop where init val = (emptyOrSingleton accepted val, accepted) where @@ -484,7 +515,7 @@ -- ** Reversal reverse :: Changeable a => Seq a ->> Seq a -reverse = MultiChange.map $ stateTrans init prop where +reverse = MultiChange.map $ stateTrans' init prop where init seq = (Seq.reverse seq, Seq.length seq) @@ -510,10 +541,12 @@ -- ** Sorting +data Tagged o val = Tagged !val !(Element o) deriving (Eq, Ord) + sort :: (Ord a, Changeable a) => Seq a ->> Seq a sort = MultiChange.bind $ orderSTTrans (\ seq -> do let seq' = Seq.sort seq - initTaggedSeq <- traverse (\ elem -> fmap ((,) elem) newMaximum) seq + initTaggedSeq <- traverse (\ elem -> fmap (Tagged elem) newMaximum) seq let initTaggedSet = Set.fromList (toList initTaggedSeq) taggedSeqRef <- lift $ newSTRef initTaggedSeq taggedSetRef <- lift $ newSTRef initTaggedSet @@ -521,22 +554,23 @@ taggedSeq <- lift $ readSTRef taggedSeqRef let (front, rest) = Seq.splitAt ix taggedSeq tag <- case Seq.viewl rest of - Seq.EmptyL -> newMaximum - (_, neighborTag) Seq.:< _ -> newBefore neighborTag - lift $ writeSTRef taggedSeqRef (front >< (elem, tag) Seq.<| rest) + Seq.EmptyL -> newMaximum + Tagged _ neighborTag Seq.:< _ -> newBefore neighborTag + lift $ writeSTRef taggedSeqRef + (front >< Tagged elem tag Seq.<| rest) oldTaggedSet <- lift $ readSTRef taggedSetRef - let newTaggedSet = Set.insert (elem, tag) oldTaggedSet + let newTaggedSet = Set.insert (Tagged elem tag) oldTaggedSet lift $ writeSTRef taggedSetRef newTaggedSet - return (Set.findIndex (elem, tag) newTaggedSet) + return (Set.findIndex (Tagged elem tag) newTaggedSet) let performDelete ix = do taggedSeq <- lift $ readSTRef taggedSeqRef let (front, rest) = Seq.splitAt ix taggedSeq - let (elem, tag) Seq.:< rear = Seq.viewl rest + let Tagged elem tag Seq.:< rear = Seq.viewl rest lift $ writeSTRef taggedSeqRef (front >< rear) taggedSet <- lift $ readSTRef taggedSetRef lift $ writeSTRef taggedSetRef - (Set.delete (elem, tag) taggedSet) - return (Set.findIndex (elem, tag) taggedSet) + (Set.delete (Tagged elem tag) taggedSet) + return (Set.findIndex (Tagged elem tag) taggedSet) let elemInsert ix elem = do ix' <- performInsert ix elem return (Insert ix' (Seq.singleton elem)) @@ -545,17 +579,17 @@ return (Delete ix' 1) let elemShift src tgt = do taggedSeq <- lift $ readSTRef taggedSeqRef - let elem = fst (Seq.index taggedSeq src) + let Tagged elem _ = Seq.index taggedSeq src src' <- performDelete src tgt' <- performInsert tgt elem return (Shift src' 1 tgt') - let propNorm (Insert ix seq) = do + let propCore (Insert ix seq) = do changes' <- traverse (elemInsert ix) (Prelude.reverse (toList seq)) return (MultiChange.fromList changes') - propNorm (Delete ix len) = do + propCore (Delete ix len) = do changes' <- traverse elemDelete (replicate len ix) return (MultiChange.fromList changes') - propNorm (Shift src len tgt) = (case compare src tgt of + propCore (Shift src len tgt) = (case compare src tgt of LT -> genShifts (Prelude.reverse [0 .. len - 1]) GT -> genShifts [0 .. len - 1] EQ -> return mempty) where @@ -566,20 +600,26 @@ genShift offset = elemShift (src + offset) (tgt + offset) - propNorm (ChangeAt ix change) = do + propCore (ChangeAt ix change) = do taggedSeq <- lift $ readSTRef taggedSeqRef if indexInBounds (Seq.length taggedSeq) ix then do - let (oldElem, _) = Seq.index taggedSeq ix + let Tagged oldElem _ = Seq.index taggedSeq ix let newElem = change $$ oldElem src' <- performDelete ix tgt' <- performInsert ix newElem return (shift src' 1 tgt' `mappend` changeAt src' change) else return mempty let prop change = do - taggedSeq <- lift $ readSTRef taggedSeqRef - propNorm (normalizeAtomicChange (Seq.length taggedSeq) change) - return (seq', prop)) + oldTaggedSeq <- lift $ readSTRef taggedSeqRef + change' <- propCore $ + normalizeAtomicChange (Seq.length oldTaggedSeq) change + newTaggedSeq <- lift $ readSTRef taggedSeqRef + newTaggedSet <- lift $ readSTRef taggedSetRef + return $ newTaggedSeq `Prelude.seq` + newTaggedSet `Prelude.seq` + change' + return (initTaggedSet `Prelude.seq` seq', prop)) orderSTTrans :: (forall o s . TransProc (OrderT o (ST s)) p q) -> Trans p q orderSTTrans transProc = trans (\ cont -> runST (evalOrderT (cont transProc))) diff --git a/src/library/Data/Incremental/Tuple.hs b/src/library/Data/Incremental/Tuple.hs --- a/src/library/Data/Incremental/Tuple.hs +++ b/src/library/Data/Incremental/Tuple.hs @@ -73,6 +73,11 @@ return (first change1 `mappend` second change2) return ((val1, val2), prop)) +{-FIXME: + Could we have a strictness issue, since with fst, the changes under Second, + and with snd, the changes under First are not triggered? +-} + fst :: (Changeable a, Changeable b) => (a, b) ->> a fst = MultiChange.composeMap $ simpleTrans Prelude.fst prop where diff --git a/src/library/Data/MultiChange.hs b/src/library/Data/MultiChange.hs --- a/src/library/Data/MultiChange.hs +++ b/src/library/Data/MultiChange.hs @@ -70,12 +70,24 @@ foldMap fun (MultiChange (Dual dList)) = foldMap fun dList foldr next init (MultiChange (Dual dList)) = Foldable.foldr next init dList + {-FIXME: + Starting with GHC 7.10, Foldable.foldr can probably be written just + foldr, because the “Burning Bridges Proposal” has been implemented + (meaning that Prelude functions like foldr are now the more general + versions from Data.Foldable and Data.Traversable). + -} instance Change p => Change (MultiChange p) where type Value (MultiChange p) = Value p change $$ val = List.foldl' (flip ($$)) val (toList change) + {-FIXME: + Starting with GHC 7.10, List.foldl' can probably be written just + foldl', because the “Burning Bridges Proposal” has been implemented + (meaning that Data.List functions like foldl' are now the more general + versions from Data.Foldable and Data.Traversable). + -} -- * Construction diff --git a/src/test-suites/TestSuite.hs b/src/test-suites/TestSuite.hs deleted file mode 100644 --- a/src/test-suites/TestSuite.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module TestSuite ( - - -- * Changes - - AtomicAChange (DoubleAndAdd), - AtomicBChange (TripleAndAdd), - - -- * Test functions and transformations - - testTrans, - testFun, - testPrdTrans, - testPrdFun, - testCompare, - - -- * Test pattern - - transTest - -) where - --- Prelude - -import Prelude hiding (id, (.)) - --- Control - -import Control.Category -import Control.Applicative - --- Data - -import Data.Foldable (toList) -import Data.MultiChange (MultiChange) -import qualified Data.MultiChange as MultiChange -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import Data.Incremental -import qualified Data.Incremental.Tuple as Tuple -import qualified Data.Incremental.Sequence as Seq - --- Test - -import Test.QuickCheck -import Test.QuickCheck.Poly - --- Distribution - -import Distribution.TestSuite -import Distribution.TestSuite.QuickCheck - --- * Test data generation - -instance Arbitrary a => Arbitrary (Seq a) where - - arbitrary = fmap Seq.fromList arbitrary - - shrink seq = map Seq.fromList (shrink (toList seq)) - --- * Changes - --- ** Common changes - -instance Arbitrary a => Arbitrary (PrimitiveChange a) where - - arbitrary = frequency [(1, keepGen), (5, replaceGen)] where - - keepGen = return Keep - - replaceGen = fmap ReplaceBy arbitrary - - shrink Keep = [] - shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val) - -instance Arbitrary p => Arbitrary (MultiChange p) where - - arbitrary = fmap MultiChange.fromList arbitrary - - shrink change = map MultiChange.fromList (shrink (toList change)) - --- ** Pair changes - -deriving instance (Show (DefaultChange a), Show (DefaultChange b)) => - Show (Tuple.AtomicChange a b) - -instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) => - Arbitrary (Tuple.AtomicChange a b) where - - arbitrary = oneof [firstGen, secondGen] where - - firstGen = fmap Tuple.First arbitrary - - secondGen = fmap Tuple.Second arbitrary - - shrink (Tuple.First change) = map Tuple.First (shrink change) - shrink (Tuple.Second change) = map Tuple.Second (shrink change) - --- ** Sequence changes - -deriving instance (Show a, Show (DefaultChange a)) => Show (Seq.AtomicChange a) - -instance (Arbitrary a, Arbitrary (DefaultChange a)) => - Arbitrary (Seq.AtomicChange a) where - - arbitrary = oneof [insertGen, deleteGen, shiftGen, changeAtGen] where - - insertGen = liftA2 Seq.Insert arbitrary arbitrary - - deleteGen = liftA2 Seq.Delete arbitrary arbitrary - - shiftGen = liftA3 Seq.Shift arbitrary arbitrary arbitrary - - changeAtGen = liftA2 Seq.ChangeAt arbitrary arbitrary - - shrink (Seq.Insert ix seq) - = [Seq.Insert ix' seq' - | (ix', seq') <- shrink (ix, seq)] - shrink (Seq.Delete ix len) - = [Seq.Delete ix' len' - | (ix', len') <- shrink (ix, len)] - shrink (Seq.Shift src len tgt) - = [Seq.Shift src' len' tgt' - | (src', len', tgt') <- shrink (src, len, tgt)] - shrink (Seq.ChangeAt ix change) - = [Seq.ChangeAt ix' change' - | (ix', change') <- shrink (ix, change)] - --- ** Element changes - -newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary) - -instance Change AtomicAChange where - - type Value AtomicAChange = A - - DoubleAndAdd diff $$ A integer = A (2 * integer + diff) - -instance Changeable A where - - type DefaultChange A = MultiChange AtomicAChange - -deriving instance Ord A - -newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary) - -instance Change AtomicBChange where - - type Value AtomicBChange = B - - TripleAndAdd diff $$ B integer = B (3 * integer + diff) - -instance Changeable B where - - type DefaultChange B = MultiChange AtomicBChange - -instance Changeable C - --- * Test functions and transformations - -testTrans :: A ->> B -testTrans = MultiChange.map $ stateTrans init prop where - - init (A integer) = (B integer, integer) - - prop (DoubleAndAdd diff) state = (change', state') where - - change' = TripleAndAdd (diff - state) - - state' = 2 * state + diff - -testFun :: C -> C -testFun = id - -testPrdTrans :: A ->> Bool -testPrdTrans = MultiChange.composeMap $ stateTrans init prop where - - init (A integer) = (testPrd integer, integer) - - prop (DoubleAndAdd diff) state = (change', state') where - - change' = ReplaceBy (testPrd state') - - state' = 2 * state + diff - -testPrdFun :: C -> Bool -testPrdFun = testPrd . unC - -testPrd :: Integer -> Bool -testPrd = (>= 0) - -testCompare :: A -> A -> Ordering -testCompare (A integer1) (A integer2) = compare (integer1 `div` 3) - (integer2 `div` 3) - --- * Test pattern - -transTest :: (Show a, Arbitrary a, Changeable a, - Show (DefaultChange a), Arbitrary (DefaultChange a), - Eq b, Changeable b) => - String -> (a ->> b) -> (a -> b) -> Test -transTest name trans fun = testProperty name prop where - - prop valAndChanges = map fun (applyChanges valAndChanges) == - applyChanges valAndChanges' where - - valAndChanges' = runTrans trans valAndChanges - -applyChanges :: Change p => (Value p, [p]) -> [Value p] -applyChanges (val, changes) = scanl (flip ($$)) val changes diff --git a/src/test-suites/TestSuite/Sequence.hs b/src/test-suites/TestSuite/Sequence.hs deleted file mode 100644 --- a/src/test-suites/TestSuite/Sequence.hs +++ /dev/null @@ -1,73 +0,0 @@ -module TestSuite.Sequence ( - - tests - -) where - --- Data - -import Data.Foldable (asum) -import Data.Incremental -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import qualified Data.Incremental.Sequence as IncSeq - --- Test - -import Test.QuickCheck -import Test.QuickCheck.Poly - --- Distribution - -import Distribution.TestSuite - --- TestSuite -import TestSuite - --- * Tests - -tests :: IO [Test] -tests = return [transTest "singleton" IncSeq.singleton - (Seq.singleton :: A -> Seq A), - transTest "fromPair" IncSeq.fromPair - (seqFromPair :: (A, A) -> Seq A), - transTest "cat" IncSeq.cat - (seqCat :: (Seq A, Seq A) -> Seq A), - transTest "null" IncSeq.null - (Seq.null :: Seq A -> Bool), - transTest "length" IncSeq.length - (Seq.length :: Seq A -> Int), - transTest "map" (IncSeq.map testTrans) - (fmap (toFunction testTrans)), - transTest "map'" (IncSeq.map' testFun) - (fmap testFun), - transTest "concat" IncSeq.concat - (seqConcat :: Seq (Seq A) -> Seq A), - transTest "gate" (IncSeq.gate testPrdTrans) - (seqGate (toFunction testPrdTrans)), - transTest "gate'" (IncSeq.gate' testPrdFun) - (seqGate testPrdFun), - transTest "filter" (IncSeq.filter testPrdTrans) - (Seq.filter (toFunction testPrdTrans)), - transTest "filter'" (IncSeq.filter' testPrdFun) - (Seq.filter testPrdFun), - transTest "reverse" IncSeq.reverse - (Seq.reverse :: Seq A -> Seq A), - transTest "sort" IncSeq.sort - (Seq.sort :: Seq A -> Seq A), - transTest "sortBy" (IncSeq.sortBy testCompare) - (Seq.sortBy testCompare)] --- FIXME: Explain why we have no test for concatMap. - -seqFromPair :: (a, a) -> Seq a -seqFromPair (val1, val2) = Seq.fromList [val1, val2] - -seqCat :: (Seq a, Seq a) -> Seq a -seqCat = uncurry (Seq.><) - -seqConcat :: Seq (Seq a) -> Seq a -seqConcat = asum - -seqGate :: (a -> Bool) -> a -> Seq a -seqGate prd val | prd val = Seq.singleton val - | otherwise = Seq.empty diff --git a/src/tools/Benchmark.hs b/src/tools/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/tools/Benchmark.hs @@ -0,0 +1,120 @@ +module Benchmark ( + + runBenchmark + +) where + +-- Control + +import Control.Monad +import Control.DeepSeq +import Control.Exception + +-- Data + +import Data.Foldable (toList) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental + +-- System + +import System.CPUTime + +-- Test + +import Test.QuickCheck + +-- Utilities + +import Utilities + +{-FIXME: + Measure cumulative times. For doing so, perform first all recomputations and + then all adaptions. In each case, measure the start time and the time after + each step. +-} + +-- * Benchmarking + +runBenchmark :: (NFData a, Changeable a, NFData (DefaultChange a), + NFData b, Changeable b) + => (a -> b) + -> (a ->> b) + -> (a, [DefaultChange a]) + -> IO () +runBenchmark fun trans src = do + timePairs <- benchmark fun trans src + zipWithM_ outputTimePair [0 ..] timePairs + +data TimePair = TimePair { + recomputeTime :: Integer, + adaptTime :: Integer + } + +benchmark :: (NFData a, Changeable a, NFData (DefaultChange a), + NFData b, Changeable b) + => (a -> b) + -> (a ->> b) + -> (a, [DefaultChange a]) + -> IO [TimePair] +benchmark fun trans src = do + fullyEvaluatedSrc <- fullyEvaluate src + let recomputeResults = recompute fun fullyEvaluatedSrc + let adaptResults = adapt trans fullyEvaluatedSrc + recomputeTimes <- getTimes recomputeResults + adaptTimes <- getTimes adaptResults + return $ zipWith TimePair recomputeTimes adaptTimes + +getTimes :: NFData b => [b] -> IO [Integer] +getTimes results = do + startTime <- getCPUTime + let getTime result = do + fullyEvaluate result + finishTime <- getCPUTime + return (finishTime - startTime) + mapM getTime results + +fullyEvaluate :: NFData a => a -> IO a +fullyEvaluate = evaluate . force + +outputTimePair :: Int -> TimePair -> IO () +outputTimePair stepNo timePair = putStrLn $ + align stepNoWidth stepNo ++ + ": R " ++ + timeOutput (recomputeTime timePair) ++ + ", A " ++ + timeOutput (adaptTime timePair) + +timeOutput :: Integer -> String +timeOutput time = align timeIntegralWidth (inCentiseconds `div` 100) ++ + "." ++ + show (fractionalPart `div` 10) ++ + show (fractionalPart `mod` 10) ++ + " s" where + + inCentiseconds = (time + 5000000000) `div` 10000000000 + + fractionalPart = inCentiseconds `mod` 100 + +align :: Show a => Int -> a -> String +align width val = Prelude.reverse $ + take width $ + Prelude.reverse (show val) ++ repeat ' ' + +stepNoWidth :: Int +stepNoWidth = 8 + +timeIntegralWidth :: Int +timeIntegralWidth = 4 + +-- * Evaluation of changes + +instance NFData a => NFData (PrimitiveChange a) where + + rnf Keep = () + rnf (ReplaceBy val) = val `deepseq` () + +instance NFData p => NFData (MultiChange p) where + + rnf change = rnf (toList change) diff --git a/src/tools/Benchmark/Sequence.hs b/src/tools/Benchmark/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/tools/Benchmark/Sequence.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE UndecidableInstances #-} +module Main ( + + main + +) where + +-- Control + +import Control.DeepSeq + +-- Data + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Incremental +import Data.Incremental.Sequence as IncSeq + +-- Test + +import Test.QuickCheck + +-- Benchmark + +import Benchmark + +main :: IO () +main = do + performSortBenchmark 10000 10 + performSortBenchmark 100000 10 + performSortBenchmark 1000000 10 + +-- * Benchmarking + +performSortBenchmark :: Int -> Int -> IO () +performSortBenchmark = performBenchmark (Seq.sort :: Seq Int -> Seq Int) + IncSeq.sort + +performBenchmark :: (Arbitrary a, NFData a, Changeable a, + DefaultChange a ~ PrimitiveChange a, + Arbitrary b, NFData b, Changeable b) + => (Seq a -> Seq b) + -> (Seq a ->> Seq b) + -> Int + -> Int + -> IO () +performBenchmark fun trans initLen changeCount = do + putStrLn $ "Length of initial sequence: " ++ show initLen + putStrLn $ "Number of changes: " ++ show changeCount + src <- generate $ srcGen initLen changeCount + runBenchmark fun trans src + +-- * Benchmark data generation + +srcGen :: (Arbitrary a, Changeable a, DefaultChange a ~ PrimitiveChange a) + => Int + -> Int + -> Gen (Seq a, [DefaultChange (Seq a)]) +srcGen initLen changeCount = do + seq <- seqGen initLen + changes <- changesGen initLen changeCount + return (seq, changes) where + + changesGen len changeCount + | changeCount == 0 = return [] + | otherwise = do + (change, lenDiff) <- changeAndLengthDiffGen len + changes <- changesGen (len + lenDiff) (pred changeCount) + return (change : changes) + +-- | Generates a sequence of the given length. +seqGen :: Arbitrary a => Int -> Gen (Seq a) +seqGen len = do + elems <- vectorOf len arbitrary + return (Seq.fromList elems) + +{-| + Generates a sequence change that deals with only a single element and stays + within the bounds of the sequence, along with the change in length that this + change causes. +-} +changeAndLengthDiffGen :: (Arbitrary a, + Changeable a, + DefaultChange a ~ PrimitiveChange a) + => Int + -> Gen (DefaultChange (Seq a), Int) +changeAndLengthDiffGen len + | len == 0 = insertGen + | otherwise = oneof [insertGen, deleteGen, shiftGen, changeAtGen] where + + insertGen = do + ix <- choose (0, len) + elem <- arbitrary + return (insert ix (Seq.singleton elem), 1) + + deleteGen = do + ix <- choose (0, pred len) + return (delete ix 1, -1) + + shiftGen = do + src <- choose (0, pred len) + tgt <- choose (0, pred len) + return (shift src 1 tgt, 0) + + changeAtGen = do + ix <- choose (0, pred len) + newElem <- arbitrary + return (changeAt ix (ReplaceBy newElem), 0) + +-- * Evaluation of changes + +instance (NFData a, NFData (DefaultChange a)) => NFData (AtomicChange a) where + + rnf (Insert ix seq) = ix `deepseq` seq `deepseq` () + rnf (Delete ix len) = ix `deepseq` len `deepseq` () + rnf (Shift src len tgt) = src `deepseq` len `deepseq` tgt `deepseq` () + rnf (ChangeAt ix change) = ix `deepseq` change `deepseq` () diff --git a/src/tools/TestSuite.hs b/src/tools/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/tools/TestSuite.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE UndecidableInstances #-} +module TestSuite ( + + -- * Changes + + AtomicAChange (DoubleAndAdd), + AtomicBChange (TripleAndAdd), + + -- * Test functions and transformations + + testTrans, + testFun, + testPrdTrans, + testPrdFun, + testCompare, + + -- * Test pattern + + transTest + +) where + +-- Prelude + +import Prelude hiding (id, (.)) + +-- Control + +import Control.Category +import Control.Applicative + +-- Data + +import Data.Foldable (toList) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple +import qualified Data.Incremental.Sequence as Seq + +-- Test + +import Test.QuickCheck +import Test.QuickCheck.Poly + +-- Distribution + +import Distribution.TestSuite +import Distribution.TestSuite.QuickCheck + +-- Utilities + +import Utilities + +-- * Changes + +-- ** Common changes + +instance Arbitrary a => Arbitrary (PrimitiveChange a) where + + arbitrary = frequency [(1, keepGen), (5, replaceGen)] where + + keepGen = return Keep + + replaceGen = fmap ReplaceBy arbitrary + + shrink Keep = [] + shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val) + +instance Arbitrary p => Arbitrary (MultiChange p) where + + arbitrary = fmap MultiChange.fromList arbitrary + + shrink change = map MultiChange.fromList (shrink (toList change)) + +-- ** Pair changes + +deriving instance (Show (DefaultChange a), Show (DefaultChange b)) => + Show (Tuple.AtomicChange a b) + +instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) => + Arbitrary (Tuple.AtomicChange a b) where + + arbitrary = oneof [firstGen, secondGen] where + + firstGen = fmap Tuple.First arbitrary + + secondGen = fmap Tuple.Second arbitrary + + shrink (Tuple.First change) = map Tuple.First (shrink change) + shrink (Tuple.Second change) = map Tuple.Second (shrink change) + +-- ** Sequence changes + +deriving instance (Show a, Show (DefaultChange a)) => Show (Seq.AtomicChange a) + +instance (Arbitrary a, Arbitrary (DefaultChange a)) => + Arbitrary (Seq.AtomicChange a) where + + arbitrary = oneof [insertGen, deleteGen, shiftGen, changeAtGen] where + + insertGen = liftA2 Seq.Insert arbitrary arbitrary + + deleteGen = liftA2 Seq.Delete arbitrary arbitrary + + shiftGen = liftA3 Seq.Shift arbitrary arbitrary arbitrary + + changeAtGen = liftA2 Seq.ChangeAt arbitrary arbitrary + + shrink (Seq.Insert ix seq) + = [Seq.Insert ix' seq' + | (ix', seq') <- shrink (ix, seq)] + shrink (Seq.Delete ix len) + = [Seq.Delete ix' len' + | (ix', len') <- shrink (ix, len)] + shrink (Seq.Shift src len tgt) + = [Seq.Shift src' len' tgt' + | (src', len', tgt') <- shrink (src, len, tgt)] + shrink (Seq.ChangeAt ix change) + = [Seq.ChangeAt ix' change' + | (ix', change') <- shrink (ix, change)] + +-- ** Element changes + +newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicAChange where + + type Value AtomicAChange = A + + DoubleAndAdd diff $$ A integer = A (2 * integer + diff) + +instance Changeable A where + + type DefaultChange A = MultiChange AtomicAChange + +deriving instance Ord A + +newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicBChange where + + type Value AtomicBChange = B + + TripleAndAdd diff $$ B integer = B (3 * integer + diff) + +instance Changeable B where + + type DefaultChange B = MultiChange AtomicBChange + +instance Changeable C + +-- * Test functions and transformations + +testTrans :: A ->> B +testTrans = MultiChange.map $ stateTrans init prop where + + init (A integer) = (B integer, integer) + + prop (DoubleAndAdd diff) state = (change', state') where + + change' = TripleAndAdd (diff - state) + + state' = 2 * state + diff + +testFun :: C -> C +testFun = id + +testPrdTrans :: A ->> Bool +testPrdTrans = MultiChange.composeMap $ stateTrans init prop where + + init (A integer) = (testPrd integer, integer) + + prop (DoubleAndAdd diff) state = (change', state') where + + change' = ReplaceBy (testPrd state') + + state' = 2 * state + diff + +testPrdFun :: C -> Bool +testPrdFun = testPrd . unC + +testPrd :: Integer -> Bool +testPrd = (>= 0) + +testCompare :: A -> A -> Ordering +testCompare (A integer1) (A integer2) = compare (integer1 `div` 3) + (integer2 `div` 3) + +-- * Test pattern + +transTest :: (Show a, Arbitrary a, Changeable a, + Show (DefaultChange a), Arbitrary (DefaultChange a), + Eq b, Changeable b) => + String -> (a ->> b) -> (a -> b) -> Test +transTest name trans fun = testProperty name prop where + + prop src = recompute fun src == adapt trans src diff --git a/src/tools/TestSuite/Sequence.hs b/src/tools/TestSuite/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/tools/TestSuite/Sequence.hs @@ -0,0 +1,74 @@ +module TestSuite.Sequence ( + + tests + +) where + +-- Data + +import Data.Foldable (asum) +import Data.Incremental +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Incremental.Sequence as IncSeq + +-- Test + +import Test.QuickCheck +import Test.QuickCheck.Poly + +-- Distribution + +import Distribution.TestSuite + +-- TestSuite + +import TestSuite + +-- * Tests + +tests :: IO [Test] +tests = return [{-transTest "singleton" IncSeq.singleton + (Seq.singleton :: A -> Seq A), + transTest "fromPair" IncSeq.fromPair + (seqFromPair :: (A, A) -> Seq A), + transTest "cat" IncSeq.cat + (seqCat :: (Seq A, Seq A) -> Seq A), + transTest "null" IncSeq.null + (Seq.null :: Seq A -> Bool), + transTest "length" IncSeq.length + (Seq.length :: Seq A -> Int), + transTest "map" (IncSeq.map testTrans) + (fmap (toFunction testTrans)), + transTest "map'" (IncSeq.map' testFun) + (fmap testFun), + transTest "concat" IncSeq.concat + (seqConcat :: Seq (Seq A) -> Seq A), + transTest "gate" (IncSeq.gate testPrdTrans) + (seqGate (toFunction testPrdTrans)), + transTest "gate'" (IncSeq.gate' testPrdFun) + (seqGate testPrdFun), + transTest "filter" (IncSeq.filter testPrdTrans) + (Seq.filter (toFunction testPrdTrans)), + transTest "filter'" (IncSeq.filter' testPrdFun) + (Seq.filter testPrdFun), + transTest "reverse" IncSeq.reverse + (Seq.reverse :: Seq A -> Seq A), + transTest "sort" IncSeq.sort + (Seq.sort :: Seq A -> Seq A), + transTest "sortBy" (IncSeq.sortBy testCompare) + (Seq.sortBy testCompare)-}] +-- FIXME: Explain why we have no test for concatMap. + +seqFromPair :: (a, a) -> Seq a +seqFromPair (val1, val2) = Seq.fromList [val1, val2] + +seqCat :: (Seq a, Seq a) -> Seq a +seqCat = uncurry (Seq.><) + +seqConcat :: Seq (Seq a) -> Seq a +seqConcat = asum + +seqGate :: (a -> Bool) -> a -> Seq a +seqGate prd val | prd val = Seq.singleton val + | otherwise = Seq.empty diff --git a/src/tools/Utilities.hs b/src/tools/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/tools/Utilities.hs @@ -0,0 +1,23 @@ +module Utilities ( + + recompute, + adapt + +) where + +-- Data + +import Data.Incremental + +recompute :: (Changeable a, Changeable b) + => (a -> b) + -> (a, [DefaultChange a]) -> [b] +recompute fun src = map fun (applyChanges src) + +adapt :: (Changeable a, Changeable b) + => (a ->> b) + -> (a, [DefaultChange a]) -> [b] +adapt trans src = applyChanges (runTrans trans src) + +applyChanges :: Change p => (Value p, [p]) -> [Value p] +applyChanges (val, changes) = scanl (flip ($$)) val changes