increments (empty) → 0.1.0.2
raw patch · 8 files changed
+793/−0 lines, 8 filesdep +QuickCheckdep +basedep +beamablesetup-changed
Dependencies added: QuickCheck, base, beamable, bytestring, containers, ghc-prim, test-framework, test-framework-quickcheck2
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- increments.cabal +49/−0
- src/Data/Increments.hs +65/−0
- src/Data/Increments/Containers.hs +124/−0
- src/Data/Increments/Internal.hs +416/−0
- tests/TestSuite.hs +6/−0
- tests/Tests.hs +101/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, John Lato <jwlato@gmail.com>++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 John Lato <jwlato@gmail.com> nor the names of other+ 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+OWNER 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
+ increments.cabal view
@@ -0,0 +1,49 @@+-- Initial increments.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name: increments+version: 0.1.0.2+synopsis: type classes for incremental updates to data+description: incremental updates to large data structures+license: BSD3+license-file: LICENSE+author: John Lato <jwlato@gmail.com>+maintainer: jwlato@gmail.com+-- copyright: +category: Data+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: Data.Increments+ ,Data.Increments.Containers+ ,Data.Increments.Internal++ build-depends: base >=4.5 && < 4.8+ ,ghc-prim >=0.2+ ,beamable >= 0 && < 0.2+ ,bytestring >= 0.9+ ,containers >= 0.3+ hs-source-dirs: src++Test-suite increments-tests+ Ghc-options: -Wall+ Hs-source-dirs: src tests+ Main-is: TestSuite.hs+ Type: exitcode-stdio-1.0++ Other-modules:+ Tests++ Build-depends:+ test-framework >= 0.4 && < 0.9,+ test-framework-quickcheck2 >= 0.2 && < 0.4,+ QuickCheck >= 2.4 && < 2.6,++ base,+ ghc-prim,+ beamable,+ bytestring,+ containers+ hs-source-dirs: src+
+ src/Data/Increments.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ConstraintKinds #-}++{-# OPTIONS_GHC -Wall #-}++-- | Calculate incremental changes of data structures.+-- +-- The 'Incremental' class provides a set of functions that work like the unix+-- utilities 'diff' and 'patch'. 'changes' generates an incremental diff between+-- two data values. The incremental diff can then be applied by the+-- 'applyChanges' function.+--+-- The primary intention of this library is to support efficient serialization.+-- As such, default 'Increment' types are automatically provided with+-- 'Beamable' instances.+--+-- > {-# LANGUAGE DeriveGenerics #-}+-- > {-# LANGUAGE ConstraintKinds #-}+-- > {-# LANGUAGE FlexibleContexts #-}+-- > {-# LANGUAGE UndecidableInstances #-}+-- >+-- > import GHC.Generics+-- > import Data.Beamable+-- > import Data.ByteString as B+-- >+-- > data Foo a b = Foo Int (Maybe a) b deriving (Generic, Eq, Show)+-- >+-- > -- If a 'Generic' instance is available, the default definition is+-- > -- fine, after adding some constraints.+-- > instance (IncrementalCnstr a, IncrementalCnstr b) => Incremental (Foo a b)+-- >+-- > -- generate some test data+-- > foo1 = Foo 1 Nothing "foo1"+-- > foo2 = Foo 1 (Just "foo2") "foo1"+-- >+-- > -- the 'changes' function calculates an incremental changeset from+-- > -- 'foo1' to 'foo2'+-- > diff = changes foo1 foo2+-- >+-- > -- 'applyChanges' applies the changes in an incremental patch to some data+-- > -- applyChanges foo1 diff == foo2+-- > -- True+-- >+-- > -- incremental changes can be smaller (sometimes significantly smaller)+-- > -- than the data source+-- > -- B.length $ encode diff+-- > -- 8+-- > -- B.length $ encode foo2+-- > -- 12+-- +-- Incremental changes are not in general commutative or optional, and+-- it can be an error to apply a change to a data structure that doesn't match+-- the originating structure. For example:+--+-- > *Data.Increments> let diff = changes (Left 1) (Left 2 :: Either Int Char)+-- > *Data.Increments> applyChanges (Right 'a') diff+-- > *** Exception: Data.Increments: malformed Increment Rep+--+module Data.Increments (+ Incremental (..)+, Changed (..)+, IncrementalCnstr+) where++import Data.Increments.Containers ()+import Data.Increments.Internal
+ src/Data/Increments/Containers.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+-- | 'Incremental' instances for containers, and useful functions for defining+-- new instances.+module Data.Increments.Containers (+ MapLikeIncrement+, SetLikeIncrement+, changesSetLike+, applySetLike+, changesMapLike+, applyMapLike+) where++import Data.Increments.Internal++import Data.Beamable+import Data.List (foldl')+import GHC.Generics++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++data AddItem k a = AddItem k a deriving (Eq, Show, Generic)+data RemItem a = RemItem a deriving (Eq, Show, Generic)+data ModItem k a = ModItem k (Increment a) deriving (Generic)++-- | The 'Increment' of a map-like (key-value) container.+type MapLikeIncrement k a = ([AddItem k a],[RemItem k], [ModItem k a])++-- | The 'Increment' of a set.+type SetLikeIncrement a = ([AddItem () a],[RemItem a])++deriving instance (Eq (Increment a), Eq key) => Eq (ModItem key a)+deriving instance (Show (Increment a), Show key) => Show (ModItem key a)++instance (Beamable k, Beamable a) => Beamable (AddItem k a)+instance (Beamable a) => Beamable (RemItem a)+instance (Beamable k, Beamable (Increment a)) => Beamable (ModItem k a)++instance (Ord k, IncrementalCnstr a) => Incremental (Map k a) where+ type Increment (Map k a) = MapLikeIncrement k a+ changes = changesMapLike Map.toList+ applyChanges = applyMapLike Map.insert Map.delete (\k diff -> Map.update (Just . (`applyChanges` diff)) k)++instance (IncrementalCnstr a) => Incremental (IntMap a) where+ type Increment (IntMap a) = MapLikeIncrement Int a+ changes = changesMapLike IntMap.toList+ applyChanges = applyMapLike IntMap.insert IntMap.delete (\k diff -> IntMap.update (Just . (`applyChanges` diff)) k)++instance Ord a => Incremental (Set a) where+ type Increment (Set a) = SetLikeIncrement a+ changes = changesSetLike Set.toList Set.difference+ applyChanges = applySetLike Set.insert Set.delete++instance Incremental IntSet where+ type Increment IntSet = SetLikeIncrement Int+ changes = changesSetLike IntSet.toList IntSet.difference+ applyChanges = applySetLike IntSet.insert IntSet.delete++instance Changed ([AddItem a b],[RemItem c]) where+ didChange ([],[]) = False+ didChange _ = True++instance Changed (Increment e) => Changed ([AddItem a b],[RemItem c], [ModItem d e]) where+ didChange ([],[],mods) = any (\(ModItem _ diff) -> didChange diff) mods+ didChange _ = True++-- TODO: make smart instances that just create a new collection if that would be+-- more efficient.++-- | a generic 'changes' function, useful for defining instances for sets.+changesSetLike :: (c -> [a]) -> (c -> c -> c) -> c -> c -> SetLikeIncrement a+changesSetLike toList diffFn prev this =+ let adds = map (AddItem ()) . toList $ diffFn this prev+ rems = map (RemItem) . toList $ diffFn prev this+ in (adds,rems)++-- | a generic 'applyChanges' function, useful for defining instances for sets.+applySetLike :: (a -> c -> c) -> (a -> c -> c) -> c -> SetLikeIncrement a -> c+applySetLike addFn delFn cnt (adds,rems) =+ let cnt' = foldl' (\acc (RemItem x) -> delFn x acc) cnt rems+ in foldl' (\acc (AddItem _ x) -> addFn x acc) cnt' adds+++-- | a generic 'changes' function, useful for defining instances for maps.+changesMapLike :: (Ord k, IncrementalCnstr a) => (c -> [(k,a)]) -> c -> c -> MapLikeIncrement k a+changesMapLike toList prev this =+ let proc adds rems mods p@((prevKey,prevVal):prevs) t@((thisKey,thisVal):these)+ | prevKey < thisKey = proc adds (RemItem prevKey:rems) mods prevs t+ | prevKey > thisKey = proc (AddItem thisKey thisVal:adds) rems mods p these+ | otherwise = let diff = changes prevVal thisVal+ in if didChange diff+ then proc adds rems (ModItem thisKey (changes prevVal thisVal):mods) prevs these+ else proc adds rems mods prevs these+ proc adds rems mods prevs [] = (reverse adds, reverse rems ++ map (RemItem . fst) prevs, reverse mods)+ proc adds rems mods [] these = (reverse adds ++ map (uncurry AddItem) these, reverse rems, reverse mods)+ in proc [] [] [] (toList prev) (toList this)++-- | a generic 'applyChanges' function, useful for defining instances for maps.+applyMapLike :: Incremental a+ => (k -> a -> c -> c)+ -> (k -> c -> c)+ -> (k -> Increment a -> c -> c)+ -> c+ -> MapLikeIncrement k a+ -> c+applyMapLike addFn delFn modFn cnt (adds,rems,mods) =+ let cntPruned = foldl' (\acc (RemItem k) -> delFn k acc) cnt rems+ cntAdded = foldl' (\acc (AddItem k x) -> addFn k x acc) cntPruned adds+ in foldl' (\acc (ModItem k diff) -> modFn k diff acc) cntAdded mods
+ src/Data/Increments/Internal.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS -Wall -fno-warn-orphans #-}+-- | Internal functions; typically unneeded by users.+--+-- One common case is defining certain Incremental instances. Sometimes+-- instead of deriving an Incremental instance you want to always send new data+-- if it has changed. This is easily supported with the `DPrim` type and+-- helper functions:+--+-- > import Data.Increments.Internal+-- >+-- > instance Incremental Foo where+-- > type Increment Foo = DPrim Foo+-- > changes = iprimDiff+-- > applyChanges = iprimApply+--+-- This is especially useful with large types that do not change often, when+-- attempting to calculate the difference may be very expensive.+--+module Data.Increments.Internal (+ Incremental (..)+, Changed (..)+, IncrementalCnstr+-- * helpers for creating instances for primitive-ish types+, DPrim (..)+, iprimDiff+, iprimApply+) where++import Control.Arrow (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Int+import Data.Monoid+import Data.Word+import GHC.Generics++import Data.Beamable+import Data.Beamable.Internal++----------------------------------------+-- int types++instance Incremental Integer where+ type Increment Integer = DPrim Integer+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Int where+ type Increment Int = DPrim Int+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Int8 where+ type Increment Int8 = DPrim Int8+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Int16 where+ type Increment Int16 = DPrim Int16+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Int32 where+ type Increment Int32 = DPrim Int32+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Int64 where+ type Increment Int64 = DPrim Int64+ changes = iprimDiff+ applyChanges = iprimApply++----------------------------------------+-- Word types++instance Incremental Word where+ type Increment Word = DPrim Word+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Word8 where+ type Increment Word8 = DPrim Word8+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Word16 where+ type Increment Word16 = DPrim Word16+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Word32 where+ type Increment Word32 = DPrim Word32+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Word64 where+ type Increment Word64 = DPrim Word64+ changes = iprimDiff+ applyChanges = iprimApply++----------------------------------------+-- floating types++instance Incremental Float where+ type Increment Float = DPrim Float+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Double where+ type Increment Double = DPrim Double+ changes = iprimDiff+ applyChanges = iprimApply++----------------------------------------+-- other basic, non-derived instances++instance Eq x => Incremental [x] where+ type Increment [x] = DPrim [x]+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental Char where+ type Increment Char = DPrim Char+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental B.ByteString where+ type Increment B.ByteString = DPrim B.ByteString+ changes = iprimDiff+ applyChanges = iprimApply++instance Incremental BL.ByteString where+ type Increment BL.ByteString = DPrim BL.ByteString+ changes = iprimDiff+ applyChanges = iprimApply++----------------------------------------+-- derived instances++instance Changed () where+ didChange _ = False++instance Incremental ()+instance Incremental Ordering+instance Incremental Bool+instance (Incremental a, Changed (Increment a)) => Incremental (Maybe a)+instance (Incremental l, Incremental r, Changed (Increment l), Changed (Increment r))+ => Incremental (Either l r)+++----------------------------------------+-- tuple instances++instance (IncrementalCnstr l, IncrementalCnstr r) => Incremental (l,r)+instance (IncrementalCnstr a, IncrementalCnstr b, IncrementalCnstr c) => Incremental (a,b,c)+instance (IncrementalCnstr a, IncrementalCnstr b, IncrementalCnstr c, IncrementalCnstr d) => Incremental (a,b,c,d)+instance (IncrementalCnstr a, IncrementalCnstr b, IncrementalCnstr c, IncrementalCnstr d, IncrementalCnstr e) => Incremental (a,b,c,d,e)+instance (IncrementalCnstr a, IncrementalCnstr b, IncrementalCnstr c, IncrementalCnstr d, IncrementalCnstr e, IncrementalCnstr f) => Incremental (a,b,c,d,e,f)+instance (IncrementalCnstr a, IncrementalCnstr b, IncrementalCnstr c, IncrementalCnstr d, IncrementalCnstr e, IncrementalCnstr f, IncrementalCnstr g) => Incremental (a,b,c,d,e,f,g)++-- ---------------------------------------------------------------------+-- wrap primitive-ish types in DPrim, and send new values only if there's been+-- a change++data DPrim a =+ DPrim a+ | DPrim_NoChange+ deriving (Eq, Show, Generic)++iprimDiff :: Eq a => a -> a -> DPrim a+iprimDiff a b+ | b == a = DPrim_NoChange+ | otherwise = DPrim b++iprimApply :: a -> DPrim a -> a+iprimApply _ (DPrim a) = a+iprimApply a (DPrim_NoChange) = a++instance Beamable a => Beamable (DPrim a)++instance Changed (DPrim a) where+ didChange (DPrim _) = True+ didChange DPrim_NoChange = False++instance Monoid (DPrim a) where+ mempty = DPrim_NoChange+ mappend _l r@(DPrim{}) = r+ mappend l _ = l++-- ---------------------------------------------------------------------+-- Main user-visible classes++-- | Determine if a Increment representation contains a real change. Unchanging+-- changes may be omitted.+class Changed a where+ didChange :: a -> Bool++-- | Calculate differences between data structures.+class Incremental a where+ type Increment a :: *+ -- slightly bogus, this only works because the generic param p is+ -- instantiated to (). Tough luck if that changes...+ type Increment a = GIncrement (Rep a) ()+ -- | generate the changes between the 'previous' and 'current' data+ changes :: a -> a -> Increment a+ default changes :: (Generic a, GIncremental (Rep a), GChanged (GIncrement (Rep a)), Increment a ~ GIncrement (Rep a) x) => a -> a -> Increment a+ changes a b = gchanges (from a) (from b)++ -- | Apply a changes to a value+ applyChanges :: a -> Increment a -> a+ default applyChanges :: (Generic a, GIncremental (Rep a), GChanged (GIncrement (Rep a)), Increment a ~ GIncrement (Rep a) x) => a -> Increment a -> a+ applyChanges a d_a = to $ gapplyChanges (from a) d_a++-- | A useful type constraint synonym for writing instances+type IncrementalCnstr a = (Incremental a, Changed (Increment a))++-- ---------------------------------------------------------------------+-- proxy tagged types+-- could use Data.Tagged, but those don't have generic instances, and Tagged+-- has the parameters in the wrong order.++newtype P2 a p = P2 a+ deriving (Show, Generic)++instance Beamable a => Beamable (P2 a p)+instance Changed a => Changed (P2 a p) where+ didChange (P2 a) = didChange a++data PSum a b p =+ PSNeither+ | PSLeft (GIncrement a p)+ | PSRight (GIncrement b p)+ | TLeft (a p)+ | TRight (b p)+ deriving (Generic)++deriving instance (Show (a p), Show (b p), Show (GIncrement b p), Show (GIncrement a p)) => Show (PSum a b p)++instance Changed (PSum a b p) where+ didChange PSNeither = False+ didChange _ = True++data PProd a b p =+ PPNeither+ | PPLeft (a p)+ | PPRight (b p)+ | PProd (a p) (b p)+ deriving (Show, Generic)++instance Changed (PProd a b p) where+ didChange PPNeither = False+ didChange _ = True++instance (Beamable (a p), Beamable (b p)) => Beamable (PProd a b p)+instance (Beamable (a p), Beamable (b p), Beamable (GIncrement a p), Beamable (GIncrement b p))+ => Beamable (PSum a b p)++-- ---------------------------------------------------------------------+-- generic version of Changed++class GChanged a where+ g_didChange :: a p -> Bool++instance Changed a => GChanged (P2 a) where+ g_didChange (P2 a) = didChange a++instance (GChanged (GIncrement a), GChanged (GIncrement b)) => GChanged (PSum a b) where+ g_didChange (PSLeft d) = g_didChange d+ g_didChange (PSRight d) = g_didChange d+ g_didChange PSNeither = False+ g_didChange _ = True++instance (GChanged a, GChanged b) => GChanged (PProd a b) where+ g_didChange (PProd a b) = g_didChange a || g_didChange b+ g_didChange (PPLeft a) = g_didChange a+ g_didChange (PPRight b) = g_didChange b+ g_didChange PPNeither = False++-- ---------------------------------------------------------------------+-- generic version of Incremental++class (GChanged (GIncrement f)) => GIncremental f where+ type GIncrement f :: * -> *+ gchanges :: f a -> f a -> GIncrement f a+ gapplyChanges :: f a -> GIncrement f a -> f a++instance GIncremental U1 where+ type GIncrement U1 = P2 ()+ gchanges U1 U1 = P2 ()+ gapplyChanges U1 (P2 ()) = U1++instance (GIncremental a, GIncremental b) => GIncremental (a :*: b) where+ type GIncrement (a :*: b) = PProd (GIncrement a) (GIncrement b)+ gchanges (a1 :*: b1) (a2 :*: b2) =+ let d_a = gchanges a1 a2+ d_b = gchanges b1 b2+ in case (g_didChange d_a, g_didChange d_b) of + (True, True ) -> PProd d_a d_b+ (True, False ) -> PPLeft d_a+ (False, True ) -> PPRight d_b+ (False, False) -> PPNeither+ gapplyChanges (a :*: b) (PProd d_a d_b) = gapplyChanges a d_a :*: gapplyChanges b d_b+ gapplyChanges (a :*: b) (PPLeft d_a) = gapplyChanges a d_a :*: b+ gapplyChanges (a :*: b) (PPRight d_b) = a :*: gapplyChanges b d_b+ gapplyChanges (a :*: b) (PPNeither) = a :*: b++instance (GIncremental a, GIncremental b) => GIncremental (a :+: b) where+ type GIncrement (a :+: b) = PSum a b+ gchanges (L1 a) (L1 b) = let d_a = gchanges a b+ in if g_didChange d_a+ then PSLeft d_a+ else PSNeither+ gchanges (R1 a) (R1 b) = let d_b = gchanges a b+ in if g_didChange d_b+ then PSRight d_b+ else PSNeither+ gchanges (L1 _) (R1 b) = TRight b+ gchanges (R1 _) (L1 b) = TLeft b+ gapplyChanges (L1 a) (PSLeft d)+ | g_didChange d = L1 $ gapplyChanges a d+ | otherwise = L1 a+ gapplyChanges _ (TLeft a) = L1 a+ gapplyChanges (R1 a) (PSRight d)+ | g_didChange d = R1 $ gapplyChanges a d+ | otherwise = R1 a+ gapplyChanges _ (TRight a) = R1 a+ gapplyChanges _ _ = error "Data.Increments: malformed Increment Rep"++newtype GIncrement_K1 a p = GIncrement_K1 (Increment a) deriving Generic++deriving instance (Show (Increment a)) => Show (GIncrement_K1 a p)++instance (Beamable (Increment a)) => Beamable (GIncrement_K1 a p)++instance Changed (Increment a) => Changed (GIncrement_K1 a p) where+ didChange (GIncrement_K1 a) = didChange a++instance Changed (Increment a) => GChanged (GIncrement_K1 a) where+ g_didChange (GIncrement_K1 a) = didChange a+ ++instance (Incremental a, Changed (Increment a)) => GIncremental (K1 i a) where+ type GIncrement (K1 i a) = GIncrement_K1 a+ gchanges (K1 a) (K1 b) = GIncrement_K1 $ changes a b+ gapplyChanges (K1 a) (GIncrement_K1 d_a) = K1 $ a `applyChanges` d_a++-- this instance used for datatypes with single constructor only+instance (GIncremental a, Datatype d, Constructor c) => GIncremental (M1 D d (M1 C c a)) where+ type GIncrement (M1 D d (M1 C c a)) = GIncrement a+ gchanges (M1 (M1 a)) (M1 (M1 b)) = gchanges a b+ gapplyChanges (M1 (M1 a)) d_a+ | g_didChange d_a = M1 (M1 (a `gapplyChanges` d_a))+ | otherwise = M1 (M1 a)++-- this instance used for datatypes with multiple constructors+instance (GIncremental a, Constructor c) => GIncremental (M1 C c a) where+ type GIncrement (M1 C c a) = GIncrement a+ gchanges (M1 a) (M1 b) = gchanges a b+ gapplyChanges (M1 a) d_a+ | g_didChange d_a = M1 (a `gapplyChanges` d_a)+ | otherwise = M1 a++-- this instance is needed to avoid overlapping instances with (M1 D d (M1 C c a))+instance (Datatype d, GIncremental a, GIncremental b) => GIncremental (M1 D d (a :+: b) ) where+ type GIncrement (M1 D d (a :+: b)) = GIncrement (a :+: b)+ gchanges (M1 a) (M1 b) = gchanges a b+ gapplyChanges (M1 a) d_a+ | g_didChange d_a = M1 (a `gapplyChanges` d_a)+ | otherwise = M1 a++instance (GIncremental a) => GIncremental (M1 S c a) where+ type GIncrement (M1 S c a) = GIncrement a+ gchanges (M1 a) (M1 b) = gchanges a b+ gapplyChanges (M1 a) d_a+ | g_didChange d_a = M1 (a `gapplyChanges` d_a)+ | otherwise = M1 a++instance Beamable (U1 x) where+ beam U1 = beam ()+ unbeam = first (\() -> U1) . unbeam+ typeSignR l U1 = typeSignR l ()++instance Beamable a => Beamable (K1 i a x) where+ beam (K1 a) = beam a+ unbeam = first K1 . unbeam+ typeSignR l (K1 a) = typeSignR l a++instance Beamable (a x) => Beamable (M1 s c a x) where+ beam (M1 a) = beam a+ unbeam = first M1 . unbeam+ typeSignR l (M1 a) = typeSignR l a++instance (Beamable (a x), Beamable (b x)) => Beamable ((a :*: b) x) where+ beam (a :*: b) = beam (a,b)+ unbeam = first (uncurry (:*:)) . unbeam+ typeSignR l (a :*: b) = typeSignR l (a,b)++instance (Beamable (a x), Beamable (b x)) => Beamable ((a :+: b) x) where+ beam (L1 a) = beam (Left a :: Either (a x) (b x))+ beam (R1 b) = beam (Right b :: Either (a x) (b x))+ unbeam = first (either L1 R1) . unbeam+ typeSignR l (L1 a)= typeSignR l (Left a :: Either (a x) (b x))+ typeSignR l (R1 a)= typeSignR l (Right a :: Either (a x) (b x))
+ tests/TestSuite.hs view
@@ -0,0 +1,6 @@+import Test.Framework (defaultMain)++import Tests (tests)++main :: IO ()+main = defaultMain tests
+ tests/Tests.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Tests (+ tests+, testId+) where++import Control.Applicative+import Data.Increments+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Map (Map)+import qualified Data.Map as Map++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++-- test that creating then applying a diff is equivalent to the identity+-- function+testId :: (Incremental a, Eq a) => a -> a -> Bool+testId prev this =+ let diff = changes prev this+ new = applyChanges prev diff+ in this == new++tests :: [Test]+tests =+ [ testGroup "primitive types"+ [ testProperty "Int" $ idForType pInt+ , testProperty "Char" $ idForType pChar+ , testProperty "Integer" $ idForType pInteger+ ]+ , testGroup "Tuples"+ [ testProperty "(Int,Int)" $ idForType $ pTup pInt pInt+ , testProperty "(Int,Char)" $ idForType $ pTup pInt pInt+ ]+ , testProperty "Maybe Int" $ idForType $ pMaybe pInt+ , testGroup "Either"+ [ testProperty "Either Int Char" $ idForType $ pEither pInt pChar+ , testProperty "Either Integer Integer" $ idForType $ pEither pInteger pInteger+ ]+ , testGroup "Containers"+ [ testProperty "String" $ idForType $ pList pChar+ , testProperty "[Integer]" $ idForType $ pList pInteger+ , testProperty "Map String Integer" $ idForType $ pMap (pList pChar) pInteger+ , testProperty "IntMap String" $ idForType $ pIntMap (pList pChar)+ , testProperty "Set [Int]" $ idForType $ pSet (pList pInt)+ , testProperty "IntSet" $ idForType pIntSet+ ]+ ]+ +data Proxy p = Proxy deriving (Functor)++idForType :: (Eq p, Incremental p) => Proxy p -> p -> p -> Bool+idForType _ = testId++pInt :: Proxy Int+pInt = Proxy++pChar :: Proxy Char+pChar = Proxy++pInteger :: Proxy Integer+pInteger = Proxy++pTup :: Proxy a -> Proxy b -> Proxy (a,b)+pTup _ _ = Proxy++pMaybe :: Proxy a -> Proxy (Maybe a)+pMaybe _ = Proxy++pEither :: Proxy a -> Proxy b -> Proxy (Either a b)+pEither _ _ = Proxy++pList :: Proxy a -> Proxy [a]+pList _ = Proxy++pMap :: Proxy a -> Proxy b -> Proxy (Map a b)+pMap _ _ = Proxy++pIntMap :: Proxy a -> Proxy (IntMap a)+pIntMap _ = Proxy++pIntSet :: Proxy (IntSet)+pIntSet = Proxy++pSet :: Proxy a -> Proxy (IntSet)+pSet _ = Proxy++instance (Arbitrary a, Arbitrary b, Ord a) => Arbitrary (Map a b) where+ arbitrary = Map.fromList <$> arbitrary++instance (Arbitrary b) => Arbitrary (IntMap b) where+ arbitrary = IntMap.fromList <$> arbitrary++instance Arbitrary (IntSet) where+ arbitrary = IntSet.fromList <$> arbitrary