incremental-maps (empty) → 0.0.0.0
raw patch · 11 files changed
+1783/−0 lines, 11 filesdep +Cabaldep +QuickCheckdep +aesonsetup-changed
Dependencies added: Cabal, QuickCheck, aeson, base, cabal-test-quickcheck, containers, criterion, deepseq, deepseq-generics, dlist, fingertree, incremental-maps, order-maintenance, transformers
Files
- LICENSE +58/−0
- Setup.hs +2/−0
- dist/build/map-testsStub/map-testsStub-tmp/map-testsStub.hs +5/−0
- incremental-maps.cabal +101/−0
- src/benchmarks/MapBenchmarks.hs +347/−0
- src/library/Data/Incremental.hs +348/−0
- src/library/Data/Incremental/Map.hs +470/−0
- src/library/Data/Incremental/Set.hs +34/−0
- src/library/Data/Incremental/Tuple.hs +96/−0
- src/library/Data/MultiChange.hs +128/−0
- src/test-suites/MapTests.hs +194/−0
+ LICENSE view
@@ -0,0 +1,58 @@+Copyright © 2016 Jaan Elken+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++ • Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ • Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++ • Neither the name of the copyright holders nor the names of the+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++License from incremental-computing-0.0.0.0 package:++Copyright © 2014, 2015 Denis Firsov, © 2014, 2015 Wolfgang Jeltsch+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++ • Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ • Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++ • Neither the name of the copyright holders nor the names of the+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ dist/build/map-testsStub/map-testsStub-tmp/map-testsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import MapTests ( tests )+main :: IO ()+main = stubMain tests
+ incremental-maps.cabal view
@@ -0,0 +1,101 @@+Name: incremental-maps+Version: 0.0.0.0+Synopsis: Package for doing incremental computations on maps+Description: This package is about incremental computing.+Author: Jaan Elken (supervisor Denis Firsov)+Cabal-Version: >= 1.16+Maintainer: jelken@itcollege.ee+Category: Data+License: BSD3+License-File: LICENSE+Build-Type: Simple+++Library++ Build-Depends: base >= 3.0 && < 5,+ containers >= 0.1 && < 0.6,+ dlist >= 0.7 && < 0.8,+ fingertree >= 0.1 && < 0.2,+ order-maintenance >= 0.0 && < 0.1,+ transformers >= 0.3 && < 0.5++ Default-Language: Haskell2010++ Default-Extensions: FlexibleContexts+ GeneralizedNewtypeDeriving+ RankNTypes+ TypeFamilies+ TypeOperators+ AllowAmbiguousTypes+ DeriveGeneric+++ if impl(ghc >= 7.8) {+ Default-Extensions: AutoDeriveTypeable+ }++ Exposed-Modules: Data.Incremental+ Data.Incremental.Tuple+ Data.Incremental.Map+ Data.Incremental.Set+ Data.MultiChange+++ HS-Source-Dirs: src/library++Test-Suite map-tests++ 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.8.2,+ incremental-maps == 0.0.0.0++ Default-Language: Haskell2010++ Default-Extensions: FlexibleContexts+ GeneralizedNewtypeDeriving+ StandaloneDeriving+ TypeFamilies+ TypeOperators+ TemplateHaskell++ Other-Extensions: UndecidableInstances++ Test-Module: MapTests++ HS-Source-Dirs: src/test-suites++Benchmark benchmarks++ Type: exitcode-stdio-1.0++ Main-Is: MapBenchmarks.hs++ Build-Depends: base >= 3.0 && < 5,+ aeson == 0.11.1.0,+ QuickCheck == 2.8.2,+ criterion == 1.1.1.0,+ containers >= 0.1 && < 0.6,+ deepseq-generics == 0.2.0.0,+ deepseq == 1.4.1.1,+ dlist >= 0.7 && < 0.8,+ incremental-maps == 0.0.0.0++ Default-Language: Haskell2010++ Default-Extensions: FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ StandaloneDeriving+ TypeFamilies+ TypeOperators+ DeriveGeneric++ Other-Extensions: UndecidableInstances++ HS-Source-Dirs: src/benchmarks
+ src/benchmarks/MapBenchmarks.hs view
@@ -0,0 +1,347 @@+module Main where++-- Prelude++import Prelude hiding (id, (.))++-- Control++import Control.Applicative++-- Data++import Data.Foldable (toList)+import Data.MultiChange (MultiChange)+import qualified Data.MultiChange as MultiChange+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple+import qualified Data.Incremental.Map as IncMap++-- Criterion+import Criterion.Main+import Criterion.Types+import Control.DeepSeq+import GHC.Generics hiding (C)+++-- Test++import Test.QuickCheck+import Test.QuickCheck.Poly++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.singleton 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)++-- Map changes+instance (Arbitrary k, Arbitrary (DefaultChange k),Arbitrary v, Arbitrary (DefaultChange v)) =>+ Arbitrary (IncMap.AtomicChange k v) where++ arbitrary = oneof [delete, insert] where++ delete = liftA IncMap.Delete arbitrary++ insert = liftA2 IncMap.Insert arbitrary arbitrary++ shrink (IncMap.Insert k v)+ = [IncMap.Insert k' v'+ | (k', v') <- shrink (k, v)]+ shrink (IncMap.Delete k)+ = [IncMap.Delete k'+ | k' <- shrink k]++newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary, Generic)++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, Generic)++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++deriving instance Ord B++newtype AtomicCChange = QuadrupleAndAdd Integer deriving (Show, Arbitrary, Generic)++instance Change AtomicCChange where++ type Value AtomicCChange = C++ QuadrupleAndAdd diff $$ C integer = C (4 * integer + diff)++instance Changeable C where++ type DefaultChange C = MultiChange AtomicCChange++deriving instance Ord C+++instance (NFData a) => NFData (MultiChange a)+instance NFData (Tuple.AtomicChange (Map A B) (Map A B))+instance NFData (Tuple.AtomicChange A B)+instance (Generic a, Generic b, NFData a, NFData b) => NFData (IncMap.AtomicChange a b)+instance NFData AtomicBChange+instance NFData AtomicAChange+instance NFData A+instance NFData B+instance NFData C++deriving instance (Generic a, Generic b) => Generic (IncMap.AtomicChange a b)+deriving instance Generic A+deriving instance Generic B+deriving instance Generic C++applyChanges :: Change p => (Value p, [p]) -> [Value p]+applyChanges (val, changes) = scanl (flip ($$)) val changes+++testMap r n = do+ pairs <- generate $ vectorOf n $ resize r $ arbitrary + let resultMap = Map.fromList pairs+ return resultMap++--testMapSize :: Int -> IO (Int,Int)+--testMapSize n = do+-- pairs <- generate $ vectorOf n $ resize n $ (arbitrary :: Gen (A,B)) +-- let resultMap = Map.fromList pairs+-- let resultMapSize = Map.size resultMap+-- return (n,resultMapSize)++testChanges r n = do+ changes <- generate $ vectorOf n (resize r $ arbitrary) + return changes++testFun r = do+ fun <- generate $ resize r $ arbitrary+ return fun++testKey r = do+ key <- generate $ resize r $ arbitrary+ return key++checkTrans trans (val,changes) = applyChanges (runTrans trans (val,changes))+checkOriginal trans (val,changes) = map trans (applyChanges (val,changes))++--benchmarks+main :: IO ()+main = + defaultMainWith+ (defaultConfig {reportFile = Just "performance.html"}) $ concat [+ map (benchFilter 10) [1000,10000,100000,1000000],+ map (benchMap 10) [1000,10000,100000,1000000],+ map (benchLookup 10) [1000,10000,100000,1000000],+ map (benchMember 10) [1000,10000,100000,1000000],+ map (benchPartition 10) [1000,10000,100000,1000000],+ map (benchUnion 10) [1000,10000,100000,1000000],+ map (benchDifference 10) [1000,10000,100000,1000000],+ map (benchIntersection 10) [1000,10000,100000,1000000],+ map (benchKeysSet 10) [1000,10000,100000,1000000],+ map (benchSubmapOf 10) [1000,10000,100000,1000000],+ map (benchSubmapOf 10) [1000,10000,100000,1000000],+ map (benchSplit 10) [1000,10000,100000,1000000],+ map (benchMapKeys 10) [1000,10000,100000,1000000]+ ] ++++benchFilter ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ tFun <- testFun n :: IO (B -> Bool)+ return (testValAndChanges,tFun))+ (\ ~(valAndChanges,fun) ->+ bgroup ("filter " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.filter fun)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.filter fun)) (valAndChanges !! x)) [0..ncgh]+ ])+benchMap ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ tFun <- testFun n :: IO (B -> C)+ return (testValAndChanges,tFun))+ (\ ~(valAndChanges,fun) ->+ bgroup ("map " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.map fun)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.map fun)) (valAndChanges !! x)) [0..ncgh]+ ])++benchLookup ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ tKey <- testKey n :: IO (A)+ return (testValAndChanges,tKey))+ (\ ~(valAndChanges,key) ->+ bgroup ("lookup " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.lookup key)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.lookup key)) (valAndChanges !! x)) [0..ncgh]+ ])+benchMember ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ tKey <- testKey n :: IO (A)+ return (testValAndChanges,tKey))+ (\ ~(valAndChanges,key) ->+ bgroup ("member " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.member key)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.member key)) (valAndChanges !! x)) [0..ncgh]+ ])+benchPartition ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ tFun <- testFun n :: IO (B -> Bool)+ return (testValAndChanges,tFun))+ (\ ~(valAndChanges,fun) ->+ bgroup ("partition " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.partition fun)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.partition fun)) (valAndChanges !! x)) [0..ncgh]+ ])++benchUnion ncgh n = env (do+ tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan+ return testValAndChanges)+ (\ ~(valAndChanges) ->+ bgroup ("union " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.union)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.union)) (valAndChanges !! x)) [0..ncgh]+ ])++benchDifference ncgh n = env (do+ tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan+ return testValAndChanges)+ (\ ~(valAndChanges) ->+ bgroup ("difference " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.difference)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.difference)) (valAndChanges !! x)) [0..ncgh]+ ])++benchIntersection ncgh n = env (do+ tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan+ return testValAndChanges)+ (\ ~(valAndChanges) ->+ bgroup ("intersection " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.intersection)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.intersection)) (valAndChanges !! x)) [0..ncgh]+ ])++benchKeysSet ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ return testValAndChanges)+ (\ ~(valAndChanges) ->+ bgroup ("keysSet " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.keysSet)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.keysSet)) (valAndChanges !! x)) [0..ncgh]+ ])++benchSubmapOf ncgh n = env (do+ tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap1)) tChangesScan+ return testValAndChanges)+ (\ ~(valAndChanges) ->+ bgroup ("submapOf " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.isSubmapOf)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.isSubmapOf)) (valAndChanges !! x)) [0..ncgh]+ ])++benchSplit ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tKey <- testKey n :: IO (A)+ tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ return (testValAndChanges,tKey))+ (\ ~(valAndChanges,key) ->+ bgroup ("split " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.split key)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.split key)) (valAndChanges !! x)) [0..ncgh]+ ])++benchMapKeys ncgh n = env (do+ tMap <- testMap n n :: IO (Map A B) + tFun <- testFun n :: IO (A -> C)+ tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)]+ let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges+ let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan+ return (testValAndChanges,tFun))+ (\ ~(valAndChanges,fun) ->+ bgroup ("mapKeys " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.mapKeys fun)) (valAndChanges !! x)) [0..ncgh],+ map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.mapKeys fun)) (valAndChanges !! x)) [0..ncgh]+ ])
+ src/library/Data/Incremental.hs view
@@ -0,0 +1,348 @@+module Data.Incremental (++ -- * Changes++ Change (Value, ($$)),+ PrimitiveChange (Keep, ReplaceBy),++ -- * Transformations++ Trans,+ TransProc,++ -- ** Construction++ simpleTrans,+ stateTrans,+ stTrans,+ trans,++ -- ** Deconstruction++ runTrans,+ toFunction,+ toSTProc,++ -- ** Utilities++ const,+ fromFunction,+ sanitize,++ -- * Changeables++ Changeable (DefaultChange),+ type (->>)++) where++-- Prelude++import Prelude hiding (id, (.), const)+import qualified Prelude++-- Control++import Control.Category+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe++-- Data++import Data.Monoid+import Data.Functor.Identity+import Data.STRef.Lazy++infixr 0 $$+infixr 0 ->>++{-NOTE:+ Our policy regarding class constraints with Change and Changeable is as+ follows:++ • Global values that are about changes directly and do not use ($$) (which+ are almost all of them) should not have Change constraints. Adding all+ these change constraints everywhere would give us nothing and only+ introduce clutter and possibly performance issues.++ • Global values that are about changeables (which first and foremost+ includes all that are about (->>)) should have Changeable constraints,+ because this ensures that standard changes are monoids and the value+ type of standard changes is the type that we started with.+-}++-- * Changes++class Change p where++ type Value p :: *++ -- NOTE: Operator $$ is at least not used in the base library.+ ($$) :: p -> Value p -> Value p++data PrimitiveChange a = Keep | ReplaceBy a deriving (Show, Read)++instance Functor PrimitiveChange where++ fmap _ Keep = Keep+ fmap fun (ReplaceBy val) = ReplaceBy (fun val)++instance Monoid (PrimitiveChange a) where++ mempty = Keep++ Keep `mappend` change = change+ ReplaceBy val `mappend` _ = ReplaceBy val++instance Change (PrimitiveChange a) where++ type Value (PrimitiveChange a) = a++ Keep $$ val = val+ ReplaceBy val $$ _ = val++-- * Transformations++newtype Trans p q = Trans ((Value p, [p]) -> (Value q, [q]))++instance Category Trans where++ id = Trans id++ Trans conv2 . Trans conv1 = Trans (conv2 . conv1)++type TransProc m p q = Value p -> m (Value q, p -> m q)++-- ** Construction++simpleTrans :: (Value p -> Value q) -> (p -> q) -> Trans p q+simpleTrans fun prop = trans (\ cont -> runIdentity (cont transProc)) where++ transProc val = return (fun val, return . prop)++stateTrans :: (Value p -> (Value q, s)) -> (p -> s -> (q, s)) -> Trans p q+stateTrans init prop = stTrans (\ val -> do+ let (val', initState) = init val+ stateRef <- newSTRef initState+ let stProp change = do+ oldState <- readSTRef stateRef+ let (change', newState) = prop change oldState+ writeSTRef stateRef newState+ return change'+ return (val', stProp))++stTrans :: (forall s . TransProc (ST s) p q) -> Trans p q+stTrans transProc = trans (\ cont -> runST (cont transProc))++{-NOTE:+ ST with OrderT layers around can be run as follows:++ transNested :: (forall o1 ... on s .+ TransProc (OrderT o1 (... (OrderT on (ST s)))) p q)+ -> Trans p q+ transNested transProc = trans (\ cont -> runST (+ evalOrderT (+ ... (+ evalOrderT (cont transProc)))))+-}++{-FIXME:+ We have to mention in the documentation that the monad is supposed to be+ 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.++ • The expression toSTProc trans is a processor that always yields ⊥ as the+ output value and constructs propagators that always yield ⊥ as the+ output change.+-}+trans :: (forall r . (forall m . Monad m => TransProc m p q -> m r) -> r)+ -> Trans p q+trans cpsProcAndRun = errorIfStrictMonad `seq` Trans conv where++ errorIfStrictMonad = cpsProcAndRun $+ Prelude.const (strictMonadError >> return ())++ strictMonadError = error "Data.Incremental: \+ \Transformation processor uses strict monad"++ conv valAndChanges = cpsProcAndRun $+ \ transProc -> monadicConv transProc valAndChanges++ monadicConv transProc ~(val, changes) = do+ ~(val', prop) <- transProc val+ changes' <- mapM prop changes+ return (val', changes')++-- ** Deconstruction++runTrans :: Trans p q -> (Value p, [p]) -> (Value q, [q])+runTrans (Trans conv) = conv++toFunction :: Trans p q -> (Value p -> Value q)+toFunction (Trans conv) val = fst (conv (val, undefined))++{-FIXME:+ We have to mention the following in the documentation:++ The function toSTProc . stTrans is not the identity. A computation in+ the original value of type forall s . TransProc (ST s) may yield an+ undefined state, but for computations in the constructed value,+ undefinedness can only occur in the values they output.++ On the other hand, stTrans . toSTProc is the identity. [At least, it+ should be.]+-}+{-FIXME:+ It is crucial that toSTProc cannot be called on functions of type++ (Value p, [p]) -> (Value q, [q]) ,++ but only on transformations, which correspond only to sensible, in+ particular causal, functions.++ Take, for example, the following function:++ \ ~(val, ~(change1 : ~(change2 : rest))) -> (val, change2 : change1 : rest)++ (Maybe, we do not even need to use lazy patterns.) If we would apply a+ function like toSTProc to it, and apply runTrans to the result, we would get+ a function that is not referentially transparent. Let this function be+ called f. Let us proceed as follows:++ let input = (False, [ReplaceBy False, ReplaceBy True])+ let output = f input+ let changes' = snd output+ let change1' = changes' !! 0+ let change2' = changes' !! 1++ If we now evaluate change1', we will hit ⊥, because the second input change+ has not been written into the channel. However, if we first evaluate+ change2' and then change1', then change1' will evaluate to ReplaceBy True.++ This particular problem should not occur with our toSTProc, which only works+ with transformations. If a user would reimplement toSTProc such that it+ works with arbitrary functions of the above-mentioned type, he would have to+ use unsafeInterleaveST directly, where there would be no guarantees anyhow.++ That said, we have to analyze very carefully whether our toSTProc is really+ completely safe. Only if it is, we should declare a module that contains it+ trustworthy (in the sense of Safe Haskell). We have to take into account+ that trans works with arbitrary runnable monad families and an instantiation+ of the Monad class could be bogus. The argument that running a+ transformation always yields causal functions relies on the assumption that+ the output of the first argument of (>>=) cannot depend on data that is only+ contained in the second argument of (>>=). Maybe, this assumption can be+ broken with a bogus Monad instance. But maybe, parametricity ensures that+ this assumption holds.+-}++toSTProc :: Trans p q -> TransProc (ST s) p q+toSTProc (Trans conv) val = do+ (chan, changes) <- newChannel+ let (val', changes') = conv (val, changes)+ remainderRef <- newSTRef changes'+ let prop change = do+ writeChannel chan change+ next : further <- readSTRef remainderRef+ writeSTRef remainderRef further+ return next+ return (val', prop)++-- ** Utilities++const :: Monoid q => Value q -> Trans p q+const val = simpleTrans (Prelude.const val) (Prelude.const mempty)++fromFunction :: (a -> b) -> Trans (PrimitiveChange a) (PrimitiveChange b)+fromFunction fun = simpleTrans fun (fmap fun)++sanitize :: Eq a => Trans (PrimitiveChange a) (PrimitiveChange a)+sanitize = stateTrans init prop where++ init val = (val, val)++ prop Keep state = (Keep, state)+ prop (ReplaceBy val) state = if val == state+ then (Keep, state)+ else (ReplaceBy val, val)++-- * Changeables++class (Monoid (DefaultChange a),+ Change (DefaultChange a),+ Value (DefaultChange a) ~ a) =>+ Changeable a where++ type DefaultChange a :: *+ type DefaultChange a = PrimitiveChange a++instance Changeable Bool++instance Changeable Int++{-FIXME:+ Add default instance declarations for all remaining Prelude types and+ replace them by something more decent if there is something more decent.+-}++type a ->> b = Trans (DefaultChange a) (DefaultChange b)++-- * Channels in the ST monad++data Cell s a = Cell a (CellRef s a)++type CellRef s a = STRef s (Cell s a)++type Channel s a = STRef s (CellRef s a)++newChannel :: ST s (Channel s a, [a])+newChannel = do+ cellRef <- newSTRef undefined+ chan <- newSTRef cellRef+ let getContents cellRef = unsafeInterleaveST $ do+ Cell val cellRef' <- readSTRef cellRef+ vals <- getContents cellRef'+ return (val : vals)+ -- FIXME: Is this use of unsafeInterleaveST safe?+ contents <- getContents cellRef+ return (chan, contents)++writeChannel :: Channel s a -> a -> ST s ()+writeChannel chan val = do+ cellRef <- readSTRef chan+ cellRef' <- newSTRef undefined+ writeSTRef cellRef (Cell val cellRef')+ writeSTRef chan cellRef'++{-FIXME:+ Is there already an implementation of ST channels?+-}++{-FIXME:+ Remove Control.Monad.ST.Lazy.Unsafe from the import list, if the channel+ code moves to its own module.+-}++{-FIXME:+ The following things are to be considered:++ • Does our framework correspond to update lenses? How is it related to+ update lenses? Look at the slides of Tarmo’s seminar talk from+ 11 September 2014.++ • Our work on order maintenance could be turned into a paper. Currently,+ one has to read more than one paper to understand the algorithm (Dietz+ and Sleator 1987; Willard 1986) and Dietz and Sleator (1987) do not+ explain deletion.++ • The incrementalized version of maps cannot allow conversion to sequences+ of key–value pairs, but only to sequences of values, because if the map+ was created from a sequence and was then converted to a sequence of+ key–value pairs, the choice of keys from equivalence classes of keys+ would depend on the history of changes to the original sequence, not+ just on the current value of the sequence.+-}
+ src/library/Data/Incremental/Map.hs view
@@ -0,0 +1,470 @@+module Data.Incremental.Map (++ -- * Changes++ insert,+ delete,+ id,++ -- * Atomic changes++ AtomicChange (Insert, Delete),++ -- * Transformations++ member,+ lookup,+ filter,+ map,+ partition,+ union,+ difference,+ intersection,+ isSubmapOf,+ keysSet,+ split,+ mapKeys++) where++import Prelude hiding (id,+ lookup,+ filter,+ map)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.DList (DList)+import qualified Data.DList as DList+import Data.Maybe (Maybe)+import qualified Data.Maybe as Maybe+import Data.MultiChange (MultiChange)+import qualified Data.MultiChange as MultiChange+import Data.Incremental+import qualified Data.Incremental.Tuple as Tuple+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Incremental.Set as IncSet++-- maps implementation+data AtomicChange k v = Insert k v | Delete k deriving Show++-- teeme mapi muudetavaks+instance (Ord k) => Changeable (Map k v) where++ type DefaultChange (Map k v) = MultiChange (AtomicChange k v)++insert :: (Ord k) => k -> v -> DefaultChange (Map k v)+insert k v = MultiChange.singleton (Insert k v)++delete :: (Ord k) => k -> DefaultChange (Map k v)+delete k = MultiChange.singleton (Delete k)++id :: (Ord k) => DefaultChange (Map k v)+id = MultiChange.fromList []+++instance (Ord k) => Change (AtomicChange k v) where++ type Value (AtomicChange k v) = Map k v+ Insert k v $$ m = Map.insert k v m+ Delete k $$ m = Map.delete k m++append :: AtomicChange k v -> MultiChange (AtomicChange k v) -> MultiChange (AtomicChange k v)+append change changes = mappend (MultiChange.singleton change) changes++-- teeme maybe muudetavaks+instance Changeable (Maybe a)+++empty :: Map k v+empty = Map.empty+++singleton :: (Ord k, Changeable k, Changeable v) => (k,v) ->> Map k v+singleton = MultiChange.composeMap $ stateTrans initSingleton propSingleton++type SingletonState k v = Map k v++initSingleton :: (Ord k) => (k,v) -> (Map k v,SingletonState k v)+initSingleton (k,v) = (result,state) where+ result = Map.singleton k v+ state = result++propSingleton :: (Ord k, Changeable k, Changeable v) => Tuple.AtomicChange k v -> SingletonState k v -> (MultiChange (AtomicChange k v), SingletonState k v)+propSingleton multiChange m = + case multiChange of+ (Tuple.First change) -> (mapChange, mapChange $$ m) where + mapChange = MultiChange.fromList [(Delete k),(Insert (change $$ k) v)]+ (Tuple.Second change) -> (mapChange, mapChange $$ m) where + mapChange = (insert k (change $$ v))+ where (k,v) = Map.elemAt 0 m++--member +type MemberState k = k++member :: (Ord k) => k -> (Map k v) ->> Bool+member k = MultiChange.composeMap $ stateTrans (initMember k) propMember++initMember :: (Ord k) => k -> Map k v -> (Bool, MemberState k)+initMember k m = (isMember, state) where+ isMember = Map.member k m+ state = k++propMember :: (Ord k) => (AtomicChange k v) -> MemberState k -> (PrimitiveChange Bool, MemberState k)+propMember (Insert k v) k' + | k == k' = (ReplaceBy True,k')+ | otherwise = (Keep,k')+propMember (Delete k) k' + | k == k' =(ReplaceBy False,k')+ | otherwise = (Keep,k')++--lookup +type LookupState k = k++lookup :: Ord k => k -> (Map k v) ->> Maybe v+lookup k = MultiChange.composeMap $ stateTrans (initLookup k) propLookup++initLookup :: (Ord k) => k -> Map k v -> (Maybe v, LookupState k)+initLookup k m = (result, state)+ where result = Map.lookup k m+ state = k++propLookup :: Ord k => AtomicChange k v -> LookupState k -> (PrimitiveChange (Maybe v), LookupState k)+propLookup (Insert k v) k' + | k == k' = (ReplaceBy (Just v),k')+ | otherwise = (Keep,k')+propLookup (Delete k) k' + | k == k' =(ReplaceBy Nothing,k')+ | otherwise = (Keep,k')++++--filter+type FilterState v = (v -> Bool)++filter :: (Ord k) => (v -> Bool) -> Map k v ->> Map k v+filter f = MultiChange.composeMap $ stateTrans (initFilter f) propFilter++initFilter :: (Ord k) => (v -> Bool) -> Map k v -> (Map k v, FilterState v)+initFilter f m = (result, state) + where result = Map.filter f m+ state = f++propFilter :: (Ord k) => AtomicChange k v -> FilterState v -> (MultiChange (AtomicChange k v), FilterState v)+propFilter (Insert k v) f+ | f v = (insert k v, f)+ | otherwise = (delete k, f)+propFilter (Delete k) f = (delete k, f)+++--map+type MapState v a = (v -> a)++map :: (Ord k) => (v -> a) -> Map k v ->> Map k a+map f = MultiChange.composeMap $ stateTrans (initMap f) propMap++initMap :: (Ord k) => (v -> a) -> Map k v -> (Map k a, MapState v a)+initMap f m = (result,state)+ where result = Map.map f m+ state = f++propMap :: (Ord k) => AtomicChange k v -> MapState v a -> (MultiChange (AtomicChange k a), MapState v a)+propMap (Insert k v) f = (insert k (f v),f)+propMap (Delete k) f = (delete k,f)+++--partition+type PartitionState v = ((v -> Bool))++partition :: (Ord k) => (v -> Bool) -> Map k v ->> (Map k v, Map k v)+partition f = MultiChange.composeMap $ stateTrans (initPartition f) propPartition++initPartition :: (Ord k) => (v -> Bool) -> Map k v -> ((Map k v, Map k v), PartitionState v)+initPartition f m = (result, state) + where result = Map.partition f m+ state = f ++propPartition :: (Ord k) => AtomicChange k v -> PartitionState v -> (MultiChange (Tuple.AtomicChange (Map k v) (Map k v)), PartitionState v)+propPartition mapChange f = + case mapChange of + (Insert k v) + | f v -> (MultiChange.fromList [Tuple.First (insert k v), Tuple.Second (delete k)],f)+ | otherwise -> (MultiChange.fromList [Tuple.First (delete k), Tuple.Second (insert k v)],f)+ (Delete k) -> (MultiChange.fromList [Tuple.First (delete k), Tuple.Second (delete k)],f)++--union+type UnionState k v = (Map k v, Map k v)++union :: (Ord k) => (Map k v, Map k v) ->> Map k v+union = MultiChange.composeMap $ stateTrans initUnion propUnion++initUnion :: Ord k => (Map k v, Map k v) -> (Map k v, UnionState k v)+initUnion (l,r) = (result, state)+ where result = Map.union l r+ state = (l,r)++propUnion :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> UnionState k v -> (MultiChange (AtomicChange k v), UnionState k v)+propUnion multiChange state = + case multiChange of+ (Tuple.First changes) -> foldl applyUnionLeft (id,state) changes+ (Tuple.Second changes) -> foldl applyUnionRight (id,state) changes++--hetkel ei näe võimalust neid kokku tõsta, sest need ei ole päris samasugused meetodid, mis tuleneb unioni asümmeetrilisusest.+applyUnionLeft :: Ord k => (MultiChange (AtomicChange k v), UnionState k v) -> AtomicChange k v -> (MultiChange (AtomicChange k v), UnionState k v)+applyUnionLeft (multiChange,(l,r)) change = prop change where+ prop (Delete k)+ | inFirst && inSecond == False = (append change multiChange, (change $$ l, r))+ | inFirst && inSecond = case secondElem of (Just v) -> (append (Insert k v) multiChange, (change $$ l, r))+ | otherwise = (multiChange, (l, r)) + where secondElem = Map.lookup k r+ inFirst = Map.member k l+ inSecond = Maybe.isJust secondElem+ prop (Insert k v) = (append change multiChange, (change $$ l, r)) ++applyUnionRight :: Ord k => (MultiChange (AtomicChange k v), UnionState k v) -> AtomicChange k v -> (MultiChange (AtomicChange k v), UnionState k v)+applyUnionRight (multiChange,(l,r)) change = prop change where+ prop (Delete k)+ | inFirst = (multiChange, (l, change $$ r))+ | otherwise = (append change multiChange, (l, change $$ r)) + where inFirst = Map.member k l + prop (Insert k v)+ | inFirst = (multiChange, (l, change $$ r))+ | otherwise = (append change multiChange, (l, change $$ r))+ where inFirst = Map.member k l ++--difference+type DifferenceState k v = (Map k v, Map k v)++difference :: (Ord k) => (Map k v, Map k v) ->> Map k v+difference = MultiChange.composeMap $ stateTrans initDifference propDifference++initDifference :: Ord k => (Map k v, Map k v) -> (Map k v, DifferenceState k v)+initDifference (l,r) = (result, state)+ where result = Map.difference l r+ state = (l,r)++propDifference :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> DifferenceState k v -> (MultiChange (AtomicChange k v), DifferenceState k v)+propDifference multiChange state = + case multiChange of+ (Tuple.First changes) -> foldl applyDifferenceLeft (id,state) changes+ (Tuple.Second changes) -> foldl applyDifferenceRight (id,state) changes++applyDifferenceLeft :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), (Map k v, Map k v))+applyDifferenceLeft (multiChange,(l,r)) change = + case change of+ (Insert k v)+ | inSecond == False -> (append change multiChange, (change $$ l, r))+ | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r+ (Delete k) -> (append change multiChange, (change $$ l, r)) ++applyDifferenceRight :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), (Map k v, Map k v))+applyDifferenceRight (multiChange,(l,r)) change = + case change of+ (Insert k v)+ | inFirst -> (append (Delete k) multiChange, (l, change $$ r))+ | otherwise -> (multiChange, (l, change $$ r)) + where inFirst = Map.member k l + (Delete k) -> case Map.lookup k l of + (Just v) -> (append (Insert k v) multiChange, (l, change $$ r))+ Nothing -> (multiChange, (l, change $$ r))++--intersection+type IntersectionState k v = (Map k v, Map k v)++intersection :: (Ord k) => (Map k v, Map k v) ->> Map k v+intersection = MultiChange.composeMap $ stateTrans initIntersection propIntersection++initIntersection :: Ord k => (Map k v, Map k v) -> (Map k v, IntersectionState k v)+initIntersection (l,r) = (result, state)+ where result = Map.intersection l r+ state = (l,r)++propIntersection :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> IntersectionState k v -> (MultiChange (AtomicChange k v), IntersectionState k v)+propIntersection multiChange state = + case multiChange of+ (Tuple.First changes) -> foldl applyIntersectionLeft (id,state) changes+ (Tuple.Second changes) -> foldl applyIntersectionRight (id,state) changes++applyIntersectionLeft :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), IntersectionState k v)+applyIntersectionLeft (multiChange,(l,r)) change = + case change of+ (Insert k v)+ | inSecond -> (append change multiChange, (change $$ l, r))+ | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r+ (Delete k)+ | inSecond -> (append change multiChange, (change $$ l, r))+ | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r+ ++applyIntersectionRight :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), IntersectionState k v)+applyIntersectionRight (multiChange,(l,r)) change = + case change of+ (Insert k v) ->+ case Map.lookup k l of+ (Just v) -> (append (Insert k v) multiChange, (l, change $$ r)) --testimine tuvastas vea mis sai parandatud+ Nothing -> (multiChange, (l, change $$ r)) + (Delete k)+ | inFirst -> (append change multiChange, (l, change $$ r))+ | otherwise -> (multiChange, (l, change $$ r)) + where inFirst = Map.member k l++--submap+--state: left, right, difference+--efektiivne ainult sellisel juhul, kui hulgad on piisavalt sarnased+--originaalalgoritmi puhul piisab ühest vastunäitest, et anda vastus False, seega vähim+--keerukus on O(1)! Samas allpoololevas tehakse igal juhul kolm O(log n) keerukusega operatsiooni+type SubmapOfState k v = (Map k v, Map k v, Map k v)++isSubmapOf :: (Ord k, Eq v) => (Map k v, Map k v) ->> Bool+isSubmapOf = MultiChange.composeMap $ stateTrans initSubmapOf propSubmapOf++initSubmapOf :: (Ord k, Eq v) => (Map k v, Map k v) -> (Bool, SubmapOfState k v)+initSubmapOf (l,r) = (result, state)+ where result = Map.isSubmapOf l r+ state = (l, r, Map.differenceWith discardEqualValues l r) ++discardEqualValues :: (Eq a) => (a -> a -> Maybe a)+discardEqualValues a b + | a == b = Nothing+ | otherwise = Just a++propSubmapOf :: (Ord k, Eq v) => (Tuple.AtomicChange (Map k v) (Map k v)) -> SubmapOfState k v -> (PrimitiveChange Bool, SubmapOfState k v)+propSubmapOf multiChange state = + case multiChange of+ (Tuple.First changes) -> foldl applySubmapOfLeft (Keep,state) changes+ (Tuple.Second changes) -> foldl applySubmapOfRight (Keep,state) changes++applySubmapOfLeft :: (Ord k, Eq v) => (PrimitiveChange Bool, SubmapOfState k v) -> AtomicChange k v -> (PrimitiveChange Bool, SubmapOfState k v )+applySubmapOfLeft (boolChange,(l,r,lrDiff)) change = prop change where + prop (Insert k v) = right k v (Map.lookup k r) where+ right k v (Just v') = if (v == v') + then (mappend (Keep) boolChange, (insert k v $$ l, r, delete k $$ lrDiff)) + else (mappend (ReplaceBy False) boolChange, (insert k v $$ l, r, insert k v $$ lrDiff)) + right k v (Nothing) = (mappend (ReplaceBy False) boolChange, (insert k v $$ l, r, insert k v $$ lrDiff))+ prop (Delete k) = diff k (Map.lookup k lrDiff) where+ diff k (Just _) = if (length lrDiff == 1) + then (mappend (ReplaceBy True) boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + else (mappend Keep boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + diff k (Nothing) = (mappend Keep boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + +applySubmapOfRight :: (Ord k, Eq v) => (PrimitiveChange Bool, SubmapOfState k v) -> AtomicChange k v -> (PrimitiveChange Bool, SubmapOfState k v )+applySubmapOfRight (boolChange,(l,r,lrDiff)) change = prop change where+ prop (Insert k v) = diff k v (Map.lookup k lrDiff) where+ diff k v (Just v') = if (v == v' && length lrDiff == 1) then (mappend (ReplaceBy True) boolChange, (l,insert k v' $$ r, delete k $$ lrDiff)) + else if (v == v') then (mappend (Keep) boolChange, (l,insert k v $$ r, delete k $$ lrDiff)) + else (mappend Keep boolChange, (l, insert k v $$ r, lrDiff)) + diff k v (Nothing) = left k v (Map.lookup k l) where+ left k v (Just v') = if (v == v') then (mappend Keep boolChange, (l, insert k v $$ r, lrDiff)) + else (mappend (ReplaceBy False) boolChange, (l, insert k v $$ r, insert k v' $$ lrDiff))+ left k v (Nothing) = (mappend Keep boolChange, (l, insert k v $$ r, lrDiff))+ prop (Delete k) = left k (Map.lookup k l) where+ left k (Just v') = (mappend (ReplaceBy False) boolChange, (l, delete k $$ r, insert k v' $$ lrDiff)) + left k (Nothing) = (mappend (Keep) boolChange, (l, delete k $$ r, lrDiff))+++--kas siin võiks kasutada (Map k ()) ? Aga sellisel juhul ei oleks väljund võrreldav Data.Map omaga+--keysset+keysSet :: (Ord k) => Map k v ->> (Set k)+keysSet = MultiChange.bind $ simpleTrans initKeysSet propKeysSet++initKeysSet :: (Ord k) => Map k v -> (Set k)+initKeysSet m = Map.keysSet m++propKeysSet :: (Ord k) => AtomicChange k v -> MultiChange (IncSet.AtomicChange k)+propKeysSet mapChange = + case mapChange of + (Insert k v) -> MultiChange.singleton (IncSet.Insert k)+ (Delete k) -> MultiChange.singleton (IncSet.Delete k)++--split+--O(logn ) -> O(log n), mõttetu+type SplitState k = k++split :: (Ord k) => k -> Map k v ->> (Map k v, Map k v)+split k = MultiChange.composeMap $ stateTrans (initSplit k) propSplit++initSplit :: (Ord k) => k -> Map k v -> ((Map k v, Map k v), SplitState k)+initSplit k m = (result,state)+ where result = Map.split k m + state = k++propSplit :: (Ord k) => AtomicChange k v -> SplitState k -> (MultiChange (Tuple.AtomicChange (Map k v) (Map k v)), SplitState k)+propSplit change state = + case change of+ (Insert k v) + | k < state -> (MultiChange.fromList [Tuple.First (insert k v)], state)+ | k > state -> (MultiChange.fromList [Tuple.Second (insert k v)], state)+ | otherwise -> (MultiChange.fromList [], state)+ (Delete k)+ | k < state -> (MultiChange.fromList [Tuple.First (delete k)], state)+ | k > state -> (MultiChange.fromList [Tuple.Second (delete k)], state)+ | otherwise -> (MultiChange.fromList [], state)+++--mapkeys +--values of the new keys are collapsed+--to the value of largest key (before f is applied)+type MapKeysState a b v = ((a -> b), Map b (Map a v))++mapKeys :: (Ord a, Ord b) => (a -> b) -> Map a v ->> Map b v+mapKeys fun = MultiChange.composeMap $ stateTrans (initMapKeys fun) propMapKeys++initMapKeys :: (Ord a, Ord b) => (a -> b) -> Map a v -> (Map b v, MapKeysState a b v)+initMapKeys fun m = (result,state) where+ result = Map.mapKeys fun m+ state = (fun, (Map.foldrWithKey (groupKeys fun) Map.empty m))++--creates a map of keys and list of values+groupKeys :: (Ord a, Ord b) => (a -> b) -> a -> v -> Map b (Map a v) -> Map b (Map a v)+groupKeys fun key value bMap = + let fKey = fun key+ entry = Map.lookup fKey bMap+ addTo Nothing = Map.insert fKey (Map.singleton key value) bMap+ addTo (Just aMap) = Map.insert fKey (Map.insert key value aMap) bMap+ in (addTo entry)++propMapKeys :: (Ord a, Ord b) => AtomicChange a v -> MapKeysState a b v -> (MultiChange (AtomicChange b v), MapKeysState a b v)+propMapKeys change state = prop change state where+ prop (Insert k v) (f,bMap) = (chg', (f,bMap')) where+ bMap' = updateBmap $ Map.lookup (f k) bMap+ chg' = chg $ initVal $ Map.lookup (f k) bMap'+ updateBmap Nothing = Map.insert (f k) (Map.singleton k v) bMap + updateBmap (Just aMap) = Map.insert (f k) (Map.insert k v aMap) bMap + chg Nothing = insert (f k) v+ chg (Just (_,v')) = insert (f k) v'+ initVal (Nothing) = Nothing+ initVal (Just m) = if (length m > 0) + then Just (Map.findMax m) + else Nothing+ --NOTE have to make sure, that the order of evaluation is correct+ --this can be achieved, by giving bMap' as an argument to chg'++ --loogika: + --1. uuendan bMap+ --2. otsin uue key järgi bMapist kõiki vanu vasteid+ --3. kui ei ole, siis võib teha chg Delete+ --4. kui on, siis tuleb teha suurimale vanale vastele Insert+ prop (Delete k) (f,bMap) = (chg', (f,bMap')) where + bMap' = updateBmap $ Map.lookup (f k) bMap + chg' = chg $ initVal $ Map.lookup (f k) bMap' + updateBmap Nothing = bMap + updateBmap (Just aMap) = Map.insert (f k) (Map.delete k aMap) bMap + chg Nothing = delete (f k) + chg (Just (k',v')) = insert (f k) v'+ initVal (Nothing) = Nothing+ initVal (Just m) = if (length m > 0) + then Just (Map.findMax m) + else Nothing+ --loogika: + --1. uuendan bMap+ --2. otsin uue key järgi bMapist kõiki vanu vasteid+ --3. kui ei ole, siis võib teha chg Delete+ --4. kui on, siis tuleb teha suurimale vanale vastele Insert+++++
+ src/library/Data/Incremental/Set.hs view
@@ -0,0 +1,34 @@+module Data.Incremental.Set (+ AtomicChange (Delete, Insert) +) where+++-- Data++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Monoid (Monoid (mempty, mappend))+import Data.MultiChange (MultiChange)+import qualified Data.MultiChange as MultiChange+import Data.Incremental++-- Benchmarking ++import GHC.Generics++-- * Changes++instance (Ord k) => Changeable (Set k) where++ type DefaultChange (Set k) = MultiChange (AtomicChange k)++-- * Atomic changes++data AtomicChange k = Delete k | Insert k deriving (Show,Generic)++instance (Ord k) => Change (AtomicChange k) where++ type Value (AtomicChange k) = Set k++ Delete k $$ seq = Set.delete k seq+ Insert k $$ seq = Set.insert k seq
+ src/library/Data/Incremental/Tuple.hs view
@@ -0,0 +1,96 @@+module Data.Incremental.Tuple (++ {-NOTE:+ We would have liked to re-export (,), like we re-export Seq from+ Data.Incremental.Sequence. However, we could not find a way to+ re-export (,).+ -}++ -- * Changes++ first,+ second,++ -- * Atomic changes++ AtomicChange (First, Second),++ -- * Transformations++ (&&&),+ fst,+ snd,+ swap++) where++-- Prelude++import Prelude hiding (fst, snd)+import qualified Prelude++-- Data++import Data.Monoid (Monoid (mempty, mappend))+import qualified Data.Tuple as Tuple+import Data.MultiChange (MultiChange)+import qualified Data.MultiChange as MultiChange+import Data.Incremental++-- Benchmarking ++import GHC.Generics++-- * Changes++instance (Changeable a, Changeable b) => Changeable (a, b) where+ type DefaultChange (a, b) = MultiChange (AtomicChange a b)++first :: DefaultChange a -> DefaultChange (a, b)+first = MultiChange.singleton . First++second :: DefaultChange b -> DefaultChange (a, b)+second = MultiChange.singleton . Second++-- * Atomic changes++data AtomicChange a b = First (DefaultChange a) | Second (DefaultChange b) deriving Generic++instance (Changeable a, Changeable b) => Change (AtomicChange a b) where++ type Value (AtomicChange a b) = (a, b)++ First change $$ (val1, val2) = (change $$ val1, val2)+ Second change $$ (val1, val2) = (val1, change $$ val2)+++-- * Transformations++(&&&) :: (Changeable a, Changeable b, Changeable c) =>+ (a ->> b) -> (a ->> c) -> (a ->> (b, c))+trans1 &&& trans2 = stTrans (\ val -> do+ ~(val1, prop1) <- toSTProc trans1 val+ ~(val2, prop2) <- toSTProc trans2 val+ let prop change = do+ change1 <- prop1 change+ change2 <- prop2 change+ return (first change1 `mappend` second change2)+ return ((val1, val2), prop))++fst :: (Changeable a, Changeable b) => (a, b) ->> a+fst = MultiChange.composeMap $ simpleTrans Prelude.fst prop where++ prop (First change) = change+ prop (Second _) = mempty++snd :: (Changeable a, Changeable b) => (a, b) ->> b+snd = MultiChange.composeMap $ simpleTrans Prelude.snd prop where++ prop (First _) = mempty+ prop (Second change) = change++swap :: (Changeable a, Changeable b) => (a, b) ->> (b, a)+swap = MultiChange.map $ simpleTrans Tuple.swap prop where++ prop (First change) = Second change+ prop (Second change) = First change
+ src/library/Data/MultiChange.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DeriveGeneric #-} ++module Data.MultiChange (++ -- * Type++ MultiChange,++ -- * Construction++ singleton,+ fromList,++ -- * Monad structure++ map,+ return,+ join,+ bind,++ -- * Multi composition++ compose,+ composeMap++) where++-- Prelude++import Prelude hiding (id, (.), map, return)+import qualified Prelude+{-FIXME:+ After establishment of the Applicative–Monad proposal, we have to optionally+ hide join.+-}++-- Control++import Control.Category+import Control.Arrow (second)+import Control.Monad (liftM)++-- Data++import Data.Monoid+import Data.Foldable as Foldable+import qualified Data.List as List+import Data.DList (DList)+import qualified Data.DList as DList+import Data.Incremental++-- Benchmarking ++import GHC.Generics++-- * Type++newtype MultiChange p = MultiChange (Dual (DList p)) deriving (Monoid, Generic)++instance Show p => Show (MultiChange p) where++ showsPrec prec xs = showParen (prec > 10) $+ showString "fromList " . shows (toList xs)+ -- NOTE: This is basically taken from Data.Sequence.++instance Read p => Read (MultiChange p) where++ readsPrec prec = readParen (prec > 10) $ \ str -> do+ ("fromList", rest) <- lex str+ (list, rest') <- reads rest+ Prelude.return (fromList list, rest')+ -- NOTE: This is basically taken from Data.Sequence.++instance Foldable MultiChange where++ foldMap fun (MultiChange (Dual dList)) = foldMap fun dList++ foldr next init (MultiChange (Dual dList)) = Foldable.foldr next init dList++instance Change p => Change (MultiChange p) where++ type Value (MultiChange p) = Value p++ change $$ val = List.foldl' (flip ($$)) val (toList change)++-- * Construction++singleton :: p -> MultiChange p+singleton = MultiChange . Dual . DList.singleton++{-NOTE:+ The lists are “in diagramatic order” (first atomic change at the beginning).+-}++fromList :: [p] -> MultiChange p+fromList = MultiChange . Dual . DList.fromList++-- * Monad structure++map :: Trans p q -> Trans (MultiChange p) (MultiChange q)+map trans = stTrans (\ val -> do+ ~(val', prop) <- toSTProc trans val+ let multiProp change = do+ atomics' <- mapM prop (toList change)+ Prelude.return (fromList atomics')+ Prelude.return (val', multiProp))++return :: Trans p (MultiChange p)+return = simpleTrans id singleton++join :: Trans (MultiChange (MultiChange p)) (MultiChange p)+join = compose++bind :: Trans p (MultiChange q) -> Trans (MultiChange p) (MultiChange q)+bind = composeMap++-- * Multi composition++compose :: Monoid p => Trans (MultiChange p) p+compose = simpleTrans id (mconcat . reverse . toList)+{-FIXME:+ Check whether the use of mconcat . reverse is questionable regarding space+ usage or strictness. If it is, consider using foldr (flip mappend) mempty+ instead.+-}++composeMap :: Monoid q => Trans p q -> Trans (MultiChange p) q+composeMap trans = compose . map trans
+ src/test-suites/MapTests.hs view
@@ -0,0 +1,194 @@+module MapTests 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.Map (Map)+import qualified Data.Map as Map+import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple+import qualified Data.Incremental.Map as IncMap++import Test.QuickCheck.Function+import Distribution.TestSuite.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Poly++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)++-- Map changes+instance (Arbitrary k, Arbitrary v) =>+ Arbitrary (IncMap.AtomicChange k v) where++ arbitrary = oneof [delete, insert] where++ insert = liftA2 IncMap.Insert arbitrary arbitrary++ delete = liftA IncMap.Delete arbitrary++ shrink (IncMap.Insert k v)+ = [IncMap.Insert k' v'+ | (k', v') <- shrink (k, v)]+ shrink (IncMap.Delete k)+ = [IncMap.Delete k'+ | k' <- shrink k]++newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary)++instance Change AtomicAChange where++ type Value AtomicAChange = A++ DoubleAndAdd diff $$ A integer = A (2 * integer + diff)++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)++deriving instance Ord B++newtype AtomicCChange = QuadrupleAndAdd Integer deriving (Show, Arbitrary)++instance Change AtomicCChange where++ type Value AtomicCChange = C++ QuadrupleAndAdd diff $$ C integer = C (4 * integer + diff)++deriving instance Ord C++-- * Tests+prop_lookupTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_lookupTest k valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.lookup k) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.lookup k) valAndChanges++prop_memberTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_memberTest k valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.member k) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.member k) valAndChanges++prop_filterTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_filterTest fun valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.filter f) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.filter f) valAndChanges+ f = apply fun++prop_mapTest :: Fun B C -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_mapTest fun valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.map f) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.map f) valAndChanges+ f = apply fun++prop_partitionTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_partitionTest fun valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.partition f) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.partition f) valAndChanges+ f = apply fun++prop_unionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool+prop_unionTest valAndChanges = prop valAndChanges where+ prop valAndChanges = map (uncurry Map.union) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.union) valAndChanges++prop_differenceTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool+prop_differenceTest valAndChanges = prop valAndChanges where+ prop valAndChanges = map (uncurry Map.difference) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.difference) valAndChanges++prop_intersectionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool+prop_intersectionTest valAndChanges = prop valAndChanges where+ prop valAndChanges = map (uncurry Map.intersection) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.intersection) valAndChanges++prop_keysSetTest :: ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_keysSetTest valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.keysSet) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.keysSet) valAndChanges++prop_submapOfTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool+prop_submapOfTest valAndChanges = prop valAndChanges where+ prop valAndChanges = map (uncurry Map.isSubmapOf) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.isSubmapOf) valAndChanges++prop_splitTest :: A -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_splitTest key valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.split key) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = runTrans (IncMap.split key) valAndChanges++prop_mapKeysTest :: Fun A C -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool+prop_mapKeysTest fun valAndChanges = prop valAndChanges where+ prop valAndChanges = map (Map.mapKeys f) (applyChanges valAndChanges) == applyChanges valAndChanges' where+ valAndChanges' = (runTrans (IncMap.mapKeys f) valAndChanges)+ f = apply fun++applyChanges :: (Change p) => (Value p, [p]) -> [Value p]+applyChanges (val, changes) = scanl (flip ($$)) val changes+++tests :: IO [Test]+tests = return+ [ + testProperty "lookup" prop_lookupTest+ , testProperty "member" prop_memberTest+ , testProperty "filter" prop_filterTest+ , testProperty "map" prop_mapTest+ , testProperty "partition" prop_partitionTest+ , testProperty "union" prop_unionTest+ , testProperty "difference" prop_differenceTest+ , testProperty "intersection" prop_intersectionTest+ , testProperty "keysSet" prop_keysSetTest+ , testProperty "isSubmapOf" prop_submapOfTest+ , testProperty "split" prop_splitTest+ , testProperty "mapKeys" prop_mapKeysTest+ ]++