incremental-computing 0.0.0.0 → 0.0.1.0

raw patch · 13 files changed

+754/−376 lines, 13 filesdep +deepseqdep ~QuickCheckdep ~dlistdep ~incremental-computingPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

Dependency ranges changed: QuickCheck, dlist, incremental-computing, order-maintenance, transformers

API changes (from Hackage documentation)

Files

• dist/build/sequence-testsStub/sequence-testsStub-tmp/sequence-testsStub.hs +5/−0
• incremental-computing.cabal +40/−18
• src/library/Data/Incremental.hs +48/−5
• src/library/Data/Incremental/Sequence.hs +110/−70
• src/library/Data/Incremental/Tuple.hs +5/−0
• src/library/Data/MultiChange.hs +12/−0
• src/test-suites/TestSuite.hs +0/−210
• src/test-suites/TestSuite/Sequence.hs +0/−73
• src/tools/Benchmark.hs +120/−0
• src/tools/Benchmark/Sequence.hs +117/−0
• src/tools/TestSuite.hs +200/−0
• src/tools/TestSuite/Sequence.hs +74/−0
• src/tools/Utilities.hs +23/−0

@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import TestSuite.Sequence ( tests )+main :: IO ()+main = stubMain tests

@@ -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

@@ -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?

@@ -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)))

@@ -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 

@@ -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 

@@ -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

@@ -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

@@ -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)

@@ -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` ()

@@ -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

@@ -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

@@ -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