├── LICENSE ├── README.md ├── Setup.hs ├── crdt.cabal └── src └── Data └── CRDT ├── Classes.hs ├── Counter.hs ├── Set.hs ├── Tagged.hs └── Utils.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Michael Sloan 2012 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Michael Sloan nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Work-In-Progress Commutative-Replicated-Data-Types 2 | 3 | Using this paper as a reference: http://hal.inria.fr/docs/00/55/55/88/PDF/techreport.pdf 4 | 5 | Requires trunk of https://github.com/mgsloan/these and https://github.com/mgsloan/lattices -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /crdt.cabal: -------------------------------------------------------------------------------- 1 | Name: crdt 2 | Version: 0.0.1 3 | Synopsis: 4 | Description: 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Michael Sloan 8 | Maintainer: Michael Sloan 9 | Homepage: http://github.com/mgsloan/crdt 10 | Copyright: Michael Sloan 2012 11 | Category: 12 | Build-type: Simple 13 | Extra-source-files: 14 | Data-files: 15 | Cabal-version: >=1.6 16 | Bug-Reports: http://github.com/mgsloan/crdt/issues 17 | Source-Repository head 18 | Type: git 19 | Location: git://github.com/mgsloan/crdt 20 | 21 | Library 22 | Hs-Source-Dirs: src 23 | Exposed-modules: Data.CRDT 24 | Data.CRDT.Classes 25 | Data.CRDT.Counter 26 | Data.CRDT.Set 27 | Data.CRDT.Tagged 28 | Data.CRDT.Utils 29 | Build-depends: base >= 3.0 && < 6, 30 | containers, 31 | fclabels >= 1.1 && < 1.2, 32 | lattices, 33 | newtype, 34 | newtype-th >= 0.3.2 && < 0.4, 35 | semigroups, 36 | these >= 0.1 && < 0.2, 37 | vector >= 0.4 && < 1.0 38 | Extensions: TemplateHaskell 39 | Ghc-options: -Wall 40 | -------------------------------------------------------------------------------- /src/Data/CRDT/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleInstances 3 | , NoMonomorphismRestriction 4 | , TypeFamilies 5 | , UndecidableInstances 6 | #-} 7 | 8 | module Data.CRDT.Classes where 9 | 10 | import Prelude hiding (null) 11 | 12 | import Algebra.Enumerable (Enumerable(..)) 13 | import Control.Arrow ((***)) 14 | 15 | import qualified Data.Set as S 16 | import qualified Data.IntSet as IS 17 | import qualified Data.Map as M 18 | import qualified Data.IntMap as IM 19 | 20 | 21 | -- type SetLike a = (Function a, Codomain a ~ Bool) 22 | 23 | member, notMember :: (Function a, Codomain a ~ Bool) => Domain a -> a -> Bool 24 | member = flip value 25 | notMember x = not . member x 26 | 27 | add = (`update` True) 28 | delete = (`update` zero) 29 | 30 | compose :: (Function f, Function (g b), Domain f ~ b, Functor g) 31 | => f -> g b -> g (Codomain f) 32 | compose = fmap . value 33 | 34 | 35 | class Function a where 36 | type Domain a :: * 37 | type Codomain a :: * 38 | value :: a -> Domain a -> Codomain a 39 | 40 | instance Function (k -> v) where 41 | type Domain (k -> v) = k 42 | type Codomain (k -> v) = v 43 | value = ($) 44 | 45 | instance Ord a => Function (S.Set a) where 46 | type Domain (S.Set a) = a 47 | type Codomain (S.Set a) = Bool 48 | value = flip S.member 49 | 50 | instance Function IS.IntSet where 51 | type Domain IS.IntSet = Int 52 | type Codomain IS.IntSet = Bool 53 | value = flip IS.member 54 | 55 | instance Ord k => Function (M.Map k a) where 56 | type Domain (M.Map k a) = k 57 | type Codomain (M.Map k a) = Maybe a 58 | value = flip M.lookup 59 | 60 | instance Function (IM.IntMap a) where 61 | type Domain (IM.IntMap a) = Int 62 | type Codomain (IM.IntMap a) = Maybe a 63 | value = flip IM.lookup 64 | 65 | instance (Function a, Function b) => Function (a, b) where 66 | type Domain (a, b) = ( Domain a, Domain b) 67 | type Codomain (a, b) = (Codomain a, Codomain b) 68 | value (f, g) = value f *** value g 69 | 70 | 71 | class Function a => Update a where 72 | update :: Domain a -> Codomain a -> a -> a 73 | update x y = alter (const y) x 74 | alter :: (Codomain a -> Codomain a) -> Domain a -> a -> a 75 | alter f x s = update x (f $ value s x) s 76 | 77 | instance Eq k => Update (k -> v) where 78 | update k v f x 79 | | k == x = v 80 | | otherwise = f x 81 | alter g k f x 82 | | k == x = g $ f x 83 | | otherwise = f x 84 | 85 | instance Ord a => Update (S.Set a) where 86 | update x True = S.insert x 87 | update x False = S.delete x 88 | 89 | instance Update IS.IntSet where 90 | update x True = IS.insert x 91 | update x False = IS.delete x 92 | 93 | instance Ord k => Update (M.Map k a) where 94 | update k (Just x) = M.insert k x 95 | update k Nothing = M.delete k 96 | alter = M.alter 97 | 98 | instance Update (IM.IntMap a) where 99 | update k (Just x) = IM.insert k x 100 | update k Nothing = IM.delete k 101 | alter = IM.alter 102 | 103 | instance (Update a, Update b) => Update (a, b) where 104 | update (x, x') (y, y') = update x y *** update x' y' 105 | 106 | 107 | class Zero a where 108 | zero :: a 109 | null :: a -> Bool 110 | clear :: a -> a 111 | clear = const zero 112 | 113 | instance Zero Bool where 114 | zero = False 115 | null = (==False) 116 | 117 | instance (Enumerable k, Zero v) => Zero (k -> v) where 118 | zero = zero 119 | null f = not . any (null . f) $ universe 120 | 121 | instance Zero (S.Set a) where 122 | zero = S.empty 123 | null = S.null 124 | 125 | instance Zero IS.IntSet where 126 | zero = IS.empty 127 | null = IS.null 128 | 129 | instance Zero (M.Map k a) where 130 | zero = M.empty 131 | null = M.null 132 | 133 | instance Zero (IM.IntMap a) where 134 | zero = IM.empty 135 | null = IM.null 136 | 137 | instance (Zero a, Zero b) => Zero (a, b) where 138 | zero = (zero, zero) 139 | null (a, b) = null a && null b 140 | 141 | 142 | class Size a where 143 | size :: Integral i => a -> i 144 | 145 | instance (Enumerable k, Zero v) => Size (k -> v) where 146 | size f = fromIntegral . length . filter (not . null . f) $ universe 147 | 148 | instance Size (S.Set a) where 149 | size = fromIntegral . S.size 150 | 151 | instance Size IS.IntSet where 152 | size = fromIntegral . IS.size 153 | 154 | instance Size (M.Map k a) where 155 | size = fromIntegral . M.size 156 | 157 | instance Size (IM.IntMap a) where 158 | size = fromIntegral . IM.size 159 | 160 | {- 161 | instance (Size a, Size b) => Zero (a, b) where 162 | zero = (zero, zero) 163 | null (a, b) = null a && null b 164 | -} 165 | 166 | 167 | {- 168 | class (Function a, Function b, Domain a ~ Codomain b) 169 | => Composable a b where 170 | type CompositionType a b 171 | 172 | or 173 | 174 | class ( Function r, Function a, Function b 175 | , Domain r ~ Domain b, Codomain b ~ Domain a, Codomain a ~ Codomain r 176 | ) => Composable a b r where 177 | compose :: a -> b -> CompositionType a b 178 | 179 | instance (b ~ Codomain a) => Composable (b -> c) a (Domain a -> c) where 180 | compose f g = f $ value g 181 | 182 | instance Composable (b -> c) a (Domain a -> c) where 183 | -} -------------------------------------------------------------------------------- /src/Data/CRDT/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleInstances 3 | , MultiParamTypeClasses 4 | , GeneralizedNewtypeDeriving 5 | , TemplateHaskell 6 | , TypeOperators 7 | #-} 8 | -- | CRDT Counter 9 | module Data.CRDT.Counter ( Inc, increment, incCount, Counter, count ) where 10 | 11 | import Data.CRDT.Utils 12 | 13 | newtype Inc a = Inc (Max a) deriving 14 | ( Bounded, Eq, Ord, Read, Show, JoinSemiLattice, Semigroup, PartialOrd ) 15 | 16 | --TODO: making newtype instances leaves the object open to violating CRDT. allow? 17 | $(mkNewType ''Inc) 18 | 19 | instance (Num a, PartialOrd a) => BoundedJoinSemiLattice (Inc a) where 20 | bottom = Inc $ Max 0 21 | 22 | instance (Num a, PartialOrd a) => Monoid (Inc a) where { mappend = join; mempty = bottom } 23 | 24 | increment :: (Enum a, PartialOrd a) => Inc a -> Inc a 25 | increment = Inc `over` (Max `over` succ) 26 | 27 | incCount :: PartialOrd a => Inc a :-> a 28 | incCount = lens getter setter 29 | where 30 | getter = unpack . unpack 31 | setter x = Inc `over` join (Max x) 32 | 33 | 34 | newtype Counter a = Counter (Inc a, Inc a) deriving 35 | ( Eq, Read, Show, JoinSemiLattice, BoundedJoinSemiLattice, Semigroup, Monoid ) 36 | 37 | -- TODO: Storable 38 | 39 | $(mkNewType ''Counter) 40 | 41 | instance (Enum a, Integral a, Num a, PartialOrd a) 42 | => Enum (Counter a) where 43 | succ = Counter `over` first increment 44 | pred = Counter `over` second increment 45 | toEnum i = Counter (set incCount (fromIntegral i) bottom, bottom) 46 | fromEnum = fromIntegral . get count 47 | 48 | count :: (Num a, PartialOrd a) => Counter a :-> a 49 | count = lens getter setter 50 | where 51 | getter = uncurry ((-) `on` get incCount) . unpack 52 | setter x c = pack . modifier $ unpack c 53 | where 54 | delta = x - getter c 55 | modifier 56 | | delta `leq` 0 = second $ modify incCount $ subtract delta 57 | | otherwise = first $ modify incCount $ (delta+) -------------------------------------------------------------------------------- /src/Data/CRDT/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , FlexibleInstances 4 | , MultiParamTypeClasses 5 | , GeneralizedNewtypeDeriving 6 | , TemplateHaskell 7 | , TypeFamilies 8 | , UndecidableInstances 9 | #-} 10 | module Data.CRDT.Set where 11 | 12 | import Data.CRDT.Classes 13 | import Data.CRDT.Counter 14 | import Data.CRDT.User (UserIx) 15 | import Data.CRDT.Utils 16 | 17 | import Prelude hiding (null) 18 | 19 | import Control.Applicative ((<$>)) 20 | import Control.Arrow ((***)) 21 | import Data.Label 22 | import Data.Maybe (fromMaybe) 23 | import qualified Data.Map as M 24 | import qualified Data.Set as S 25 | import qualified Data.Vector.Storable as V 26 | 27 | -- Classes 28 | 29 | --TODO: reducers? 30 | 31 | -- "G set" - growable set 32 | 33 | newtype GSet a = GSet (S.Set a) deriving 34 | ( Eq, Read, Show 35 | , Size, Update 36 | , Monoid, Semigroup 37 | , JoinSemiLattice, BoundedJoinSemiLattice, PartialOrd 38 | ) 39 | 40 | instance Ord a => Function (GSet a) where 41 | type Domain (GSet a) = a 42 | type Codomain (GSet a) = Bool 43 | value (GSet s) = value s 44 | 45 | $(mkNewType ''GSet) 46 | 47 | 48 | 49 | 50 | -- "2P set" - set with deletions where new need to have never been in the set. 51 | 52 | newtype Set2P a = Set2P (a, a) deriving 53 | ( Eq, Read, Show 54 | , Monoid, Semigroup 55 | , JoinSemiLattice, BoundedJoinSemiLattice, PartialOrd 56 | ) 57 | 58 | $(mkNewType ''Set2P) 59 | 60 | instance (Function a, Codomain a ~ Bool) => Function (Set2P a) where 61 | type Domain (Set2P a) = Domain a 62 | type Codomain (Set2P a) = Bool 63 | value (Set2P (s, d)) x = member x s && notMember x d 64 | 65 | instance (Update a, Function a, Codomain a ~ Bool) => Update (Set2P a) where 66 | update k = over Set2P . first . update k 67 | 68 | instance (Zero a, JoinSemiLattice a) => Zero (Set2P a) where 69 | zero = Set2P zero 70 | clear (Set2P (s, d)) = Set2P (s, s `join` d) 71 | 72 | instance Size a => Size (Set2P a) where 73 | size (Set2P (s, d)) = size s - size d 74 | 75 | instance Lattice a => MeetSemiLattice (Set2P a) where 76 | meet (Set2P (s, d)) (Set2P (s', d')) = Set2P (s `meet` s', d `join` d') 77 | 78 | instance BoundedLattice a => BoundedMeetSemiLattice (Set2P a) where 79 | top = Set2P (top, bottom) 80 | 81 | instance DiffLattice a => DiffLattice (Set2P a) where 82 | diff (Set2P (s, d)) (Set2P (s', d')) 83 | = Set2P (s \\ s', s' \\ s `join` d `join` d') 84 | 85 | instance (DiffLattice a, Monoid a) => ResiduatedLattice (Set2P a) where 86 | residualL = diff 87 | residualR = diff 88 | 89 | instance Lattice a => Lattice (Set2P a) 90 | instance BoundedLattice a => BoundedLattice (Set2P a) 91 | 92 | 93 | 94 | -- Set2P variant, represented as (members, deleted) instead of (seen, deleted). 95 | 96 | data RemSet a = RemSet (a, a) deriving ( Eq, Read, Show ) 97 | 98 | $(mkNewType ''RemSet) 99 | 100 | instance (Function a, Codomain a ~ Bool) => Function (RemSet a) where 101 | type Domain (RemSet a) = Domain a 102 | type Codomain (RemSet a) = Bool 103 | value (RemSet (a, _)) = value a 104 | 105 | instance (Update a, Function a, Codomain a ~ Bool) => Update (RemSet a) where 106 | update x True s@(RemSet (a, d)) 107 | | x `notMember` d = RemSet (update x True a, d) 108 | | otherwise = s 109 | update x False (RemSet (a, d)) 110 | = RemSet (update x False a, update x True d) 111 | 112 | instance (Zero a, BoundedJoinSemiLattice a) => Zero (RemSet a) where 113 | zero = RemSet (zero, zero) 114 | null = null . fst . unpack 115 | clear (RemSet (a, d)) = RemSet (bottom, a `join` d) 116 | 117 | instance Size a => Size (RemSet a) where 118 | size = size . fst . unpack 119 | 120 | instance (PartialOrd a) => PartialOrd (RemSet a) where 121 | leq (RemSet (a, d)) (RemSet (a', d')) = (a `leq` a') && (d `leq` d) 122 | 123 | instance DiffLattice a 124 | => JoinSemiLattice (RemSet a) where 125 | join (RemSet (a, d)) (RemSet (a', d')) 126 | = RemSet ( (a \\ d') `join` (a' \\ d), d `join` d') 127 | 128 | instance DiffLattice a 129 | => MeetSemiLattice (RemSet a) where 130 | meet (RemSet (a, d)) (RemSet (a', d')) 131 | = RemSet ( a `meet` a', joins [d, d', a \\ a', a' \\ a] ) 132 | 133 | instance (DiffLattice a, BoundedJoinSemiLattice a) 134 | => BoundedJoinSemiLattice (RemSet a) where 135 | bottom = RemSet (bottom, bottom) 136 | 137 | instance (DiffLattice a, BoundedLattice a) 138 | => BoundedMeetSemiLattice (RemSet a) where 139 | top = RemSet (top, bottom) 140 | 141 | instance DiffLattice a => DiffLattice (RemSet a) where 142 | diff (RemSet (a, d)) (RemSet (a', d')) 143 | = RemSet (a `diff` a', d `join` d' `join` (a' \\ a)) 144 | 145 | instance DiffLattice a => ResiduatedLattice (RemSet a) where 146 | residualL = diff 147 | residualR = diff 148 | 149 | instance DiffLattice a => Lattice (RemSet a) where 150 | instance DiffLattice a => BoundedLattice (RemSet a) where 151 | 152 | instance DiffLattice a => Semigroup (RemSet a) where 153 | (<>) = join 154 | 155 | instance DiffLattice a => Monoid (RemSet a) where 156 | mappend = join 157 | mempty = bottom 158 | 159 | 160 | -- Observed-delete Set 161 | 162 | newtype ORSet t a = ORSet (M.Map a (RemSet (S.Set t))) deriving 163 | ( Eq, Read, Show 164 | , JoinSemiLattice, BoundedJoinSemiLattice 165 | , MeetSemiLattice, BoundedMeetSemiLattice 166 | , Lattice, BoundedLattice 167 | , ResiduatedLattice, DiffLattice ) 168 | 169 | instance (Ord a, Ord t, Enumerable t) => Monoid (ORSet t a) where 170 | mappend (ORSet a) (ORSet b) = ORSet $ join a b 171 | 172 | $(mkNewType ''ORSet) 173 | 174 | instance (Ord t, Ord a) => Function (ORSet t a) where 175 | type Domain (ORSet t a) = a 176 | type Codomain (ORSet t a) = Bool 177 | value (ORSet m) = maybe False (not . null) . value m 178 | 179 | instance (Ord t, Ord a) => Zero (ORSet t a) where 180 | zero = ORSet zero 181 | null = all null . M.elems . unpack 182 | clear = over ORSet $ M.map clear 183 | 184 | instance Ord a => Size (ORSet t a) where 185 | size (ORSet m) = sum . map size $ M.elems m 186 | 187 | 188 | {- 189 | 190 | -- TODO: operational USet 191 | 192 | -- Sets that provide preferential ordering to operations: Last-Writer-Wins 193 | newtype LWWSet t a = LWWSet (M.Map a t, M.Map a t) deriving 194 | ( Eq, Read, Show, JoinSemiLattice, BoundedJoinSemiLattice, PartialOrd ) 195 | 196 | $(mkNewType ''LWWSet) 197 | 198 | instance Ord a => LWWSet a where 199 | member = uncurry (helper `on` M.lookup x) . unpack 200 | where 201 | helper (Just _) Nothing = True 202 | helper (Just t) (Just t') = t' < t 203 | helper _ _ = False 204 | update 205 | 206 | 207 | 208 | --TODO: consider take a "Tagged"? 209 | insertLWWSet :: Ord a => t -> a -> LWWSet t a -> LWWSet t a 210 | insertLWWSet t x = LWWSet `over` first (M.update x t) 211 | 212 | deleteLWWSet :: Ord a => t -> a -> LWWSet t a -> LWWSet t a 213 | deleteLWWSet t x = LWWSet `over` second (M.update x t) 214 | 215 | -- TODO: multi-register can be generalized to this as well. is it useful? 216 | 217 | 218 | 219 | -- PNSet - positive / negative set 220 | newtype PNSet t a = PNSet (M.Map a (V.Vector (Counter t))) deriving 221 | ( Eq, Read, Show, JoinSemiLattice, BoundedJoinSemiLattice, PartialOrd ) 222 | 223 | $(mkNewType ''PNSet) 224 | 225 | instance Ord a => SetLike (GSet a) where 226 | type Element (GSet a) = a 227 | member x = maybe False ((> 0) . get count) . M.lookup x . unpack 228 | 229 | alterPNSet :: (Counter t -> Counter t) -> UserIx -> a -> PNSet t a -> PNSet t a 230 | alterPNSet f u x = PNSet `over` M.alter (maybe (f bottom) $ modify (atIndex u) f) x 231 | 232 | insertPNSet, deletePNSet :: Enum t => UserIx -> a -> PNSet t a -> PNSet t a 233 | insertPNSet = alterPN succ 234 | deletePNSet = alterPN pred 235 | 236 | -} -------------------------------------------------------------------------------- /src/Data/CRDT/Tagged.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell 3 | , FlexibleInstances 4 | , MultiParamTypeClasses 5 | , GeneralizedNewtypeDeriving 6 | #-} 7 | module Data.CRDT.Tagged where 8 | 9 | import Data.CRDT.Counter 10 | import Data.CRDT.Utils 11 | 12 | import qualified Data.Vector.Storable as V 13 | 14 | -- Register that provide preferential ordering (Last-Writer-Wins) 15 | 16 | data Tagged t a = Tagged { tag :: t, untagged :: a } deriving 17 | ( Eq, Show, Read ) 18 | 19 | instance Functor (Tagged t) where 20 | fmap f (Tagged t a) = Tagged t $ f a 21 | 22 | --TODO: overload others for efficiency? 23 | instance (Ord t, Eq a) => Ord (Tagged t a) where 24 | compare = compare `on` tag 25 | 26 | instance Ord t => JoinSemiLattice (Tagged t a) where 27 | join = maxBy $ comparing tag 28 | 29 | instance (Ord t, BoundedJoinSemiLattice t, BoundedJoinSemiLattice a) 30 | => BoundedJoinSemiLattice (Tagged t a) where 31 | bottom = Tagged bottom bottom 32 | 33 | instance (PartialOrd t, Eq a) => PartialOrd (Tagged t a) where 34 | leq = leq `on` tag 35 | 36 | -- Register that provide partial preferential ordering (Multi-Value) 37 | 38 | newtype MultiTagged t a = MultiTagged [Tagged t a] deriving 39 | ( Eq, Ord, Read, Show) 40 | 41 | $(mkNewType ''MultiTagged) 42 | 43 | {- TODO (requires Storable) 44 | newtype VersionVector a = VersionVector (V.Vector (Inc a)) deriving 45 | ( Eq, Ord, Read, Show, JoinSemiLattice, BoundedJoinSemiLattice ) 46 | 47 | $(mkNewType ''VersionVector) 48 | 49 | --TODO: what about different sizes? 50 | instance (PartialOrd a) => PartialOrd (VersionVector a) where 51 | leq = VersionVector `with2` (V.and .: V.zipWith leq) 52 | 53 | instance (Eq a, PartialOrd t) => PartialOrd (MultiTagged t a) 54 | 55 | instance (Eq a, PartialOrd t) => JoinSemiLattice (MultiTagged t a) where 56 | join = MultiTagged `over2` (\xs ys -> helper xs ys ++ helper ys xs) 57 | where 58 | helper xs = filter (\v -> all (`leq` v) xs) 59 | 60 | instance (Eq a, PartialOrd t) => BoundedJoinSemiLattice (MultiTagged t a) where 61 | bottom = MultiTagged [] 62 | -} -------------------------------------------------------------------------------- /src/Data/CRDT/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DeriveDataTypeable 3 | , FlexibleInstances 4 | , GeneralizedNewtypeDeriving 5 | , MultiParamTypeClasses 6 | , NoMonomorphismRestriction 7 | , StandaloneDeriving 8 | , TemplateHaskell 9 | , TypeOperators 10 | #-} 11 | 12 | module Data.CRDT.Utils -- Re-Exports 13 | ( module Algebra.Enumerable 14 | , module Algebra.Lattice 15 | , PartialOrd(..) -- Algebra.PartialOrd 16 | , first, second, (***) -- Control.Arrow 17 | , Newtype(..), over -- Control.Newtype 18 | , mkNewType -- Control.Newtype.TH 19 | , on -- Data.Function 20 | , module Data.Label 21 | , comparing -- Data.Ord 22 | , Semigroup(..), Max(..), Monoid(..) -- Data.Semigroup 23 | , V.Storable 24 | 25 | , (.:), with2, over2, maxBy -- Utilities 26 | , union, intersection, empty, isSubsetOf, isProperSubsetOf, (\\) 27 | ) where 28 | 29 | import Algebra.Enumerable 30 | import Algebra.Lattice 31 | import Algebra.PartialOrd (PartialOrd(..)) 32 | import Control.Arrow (first, second, (***)) 33 | import Control.Newtype (Newtype(..), over) 34 | import Control.Newtype.TH (mkNewType) 35 | import Data.Align (alignWith, alignVectorWith) 36 | import Data.Function (on) 37 | import Data.Label 38 | import Data.Ord (comparing) 39 | import Data.Semigroup (Semigroup(..), Max(..), Monoid(..)) 40 | import Data.Vector.Storable ((//), (!)) 41 | import Data.These (These(..), mergeThese) 42 | import qualified Data.Vector.Generic as GV 43 | import qualified Data.Vector.Storable as V 44 | 45 | $(mkNewType ''Max) 46 | 47 | instance PartialOrd a => PartialOrd (Max a) where 48 | leq = Max `with2` leq 49 | 50 | instance PartialOrd a => JoinSemiLattice (Max a) where 51 | join = Max `over2` joinPartialOrd 52 | 53 | joinPartialOrd :: PartialOrd a => a -> a -> a 54 | joinPartialOrd x y 55 | | x `leq` y = y 56 | | y `leq` x = x 57 | | otherwise = x 58 | 59 | deriving instance V.Storable a => V.Storable (Max a) 60 | 61 | instance (JoinSemiLattice a, JoinSemiLattice b) 62 | => JoinSemiLattice (These a b) where 63 | join (This a ) (This x ) = This $ join a x 64 | join (This a ) (That y) = These a y 65 | join (This a ) (These x y) = These (join a x) y 66 | join (That b) (This x ) = These x b 67 | join (That b) (That y) = That (join b y) 68 | join (That b) (These x y) = These x (join b y) 69 | join (These a b) (This x ) = These (join a x) b 70 | join (These a b) (That y) = These a (join b y) 71 | join (These a b) (These x y) = These (join a x) (join b y) 72 | 73 | instance (V.Storable a, JoinSemiLattice a) 74 | => JoinSemiLattice (V.Vector a) where 75 | join = alignVectorWith (mergeThese join) 76 | 77 | instance (V.Storable a, BoundedJoinSemiLattice a) 78 | => BoundedJoinSemiLattice (V.Vector a) where 79 | bottom = V.empty 80 | 81 | instance (V.Storable a, PartialOrd a) 82 | => PartialOrd (V.Vector a) where 83 | leq x y = V.all id $ V.zipWith leq x y 84 | 85 | instance (JoinSemiLattice a) => JoinSemiLattice [a] where 86 | join = alignWith (mergeThese join) 87 | 88 | instance (BoundedJoinSemiLattice a) => BoundedJoinSemiLattice [a] where 89 | bottom = [] 90 | 91 | instance (PartialOrd a) => PartialOrd [a] where 92 | leq x y = all id $ zipWith leq x y 93 | 94 | (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 95 | (.:) = (.) . (.) 96 | 97 | with2 :: (Newtype a' a) => (a -> a') -> (a -> a -> c) -> a' -> a' -> c 98 | with2 _ f x y = f (unpack x) (unpack y) 99 | 100 | over2 :: (Newtype a' a) => (a -> a') -> (a -> a -> a) -> a' -> a' -> a' 101 | over2 c f = pack .: with2 c f 102 | 103 | maxBy :: (a -> a -> Ordering) -> a -> a -> a 104 | maxBy f x y = case f x y of 105 | LT -> y 106 | EQ -> x 107 | GT -> x 108 | 109 | atIndex :: GV.Vector v a => Int -> v a :-> a 110 | atIndex ix = lens (GV.! ix) ( \x -> (GV.// [(ix, x)]) ) 111 | 112 | -- Aliases 113 | 114 | union = join 115 | intersection = meet 116 | empty = bottom 117 | 118 | isSubsetOf = leq 119 | isProperSubsetOf x y = (x `leq` y) && not (y `leq` x) 120 | 121 | (\\) = diff --------------------------------------------------------------------------------