diff --git a/ot.cabal b/ot.cabal --- a/ot.cabal +++ b/ot.cabal @@ -1,5 +1,5 @@ Name: ot -Version: 0.1.2 +Version: 0.1.2.1 Synopsis: Real-time collaborative editing with Operational Transformation -- A longer description of the package. -- Description: @@ -9,16 +9,9 @@ Author: Tim Baumann Maintainer: tim@timbaumann.info --- A copyright notice. --- Copyright: - Category: Text Build-type: Simple --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.8 @@ -26,13 +19,13 @@ Library Ghc-options: -Wall Hs-source-dirs: src - Exposed-modules: Control.OperationalTransformation, Control.OperationalTransformation.Text, Control.OperationalTransformation.Properties, Control.OperationalTransformation.Client, Control.OperationalTransformation.Server + Exposed-modules: Control.OperationalTransformation, Control.OperationalTransformation.List, Control.OperationalTransformation.Text, Control.OperationalTransformation.Properties, Control.OperationalTransformation.Client, Control.OperationalTransformation.Server Build-depends: base >= 4 && < 5, - text >= 0.11.1 && < 0.12, - aeson >= 0.6.0.2 && < 0.7, + text >= 1.0 && < 1.2, + aeson >= 0.7 && < 0.9, attoparsec >= 0.10.1.1 && < 1, - QuickCheck >= 2.4.2 && < 2.6, - binary >= 0.5.1.0 + QuickCheck >= 2.7 && < 2.8, + binary >= 0.6.0.0 && < 0.8 -- Modules not exported by this package. -- Other-modules: @@ -48,7 +41,7 @@ base, text, aeson, - test-framework >= 0.6 && < 0.7, - test-framework-quickcheck2 >= 0.2.12.2 && < 0.3, - test-framework-hunit >= 0.2.7 && < 0.3, + test-framework >= 0.6 && < 0.9, + test-framework-quickcheck2 >= 0.3.0 && < 0.4, + test-framework-hunit >= 0.3.0 && < 0.4, binary >= 0.5.1.0 diff --git a/src/Control/OperationalTransformation.hs b/src/Control/OperationalTransformation.hs --- a/src/Control/OperationalTransformation.hs +++ b/src/Control/OperationalTransformation.hs @@ -7,7 +7,6 @@ ) where import Control.Monad (foldM) -import Control.Monad.Instances () class OTOperation op where -- | Transforms two concurrent operations /a/ and /b/, producing /a'/ and /b'/ diff --git a/src/Control/OperationalTransformation/List.hs b/src/Control/OperationalTransformation/List.hs new file mode 100644 --- /dev/null +++ b/src/Control/OperationalTransformation/List.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE GADTs, DataKinds, TypeFamilies #-} + +module Control.OperationalTransformation.List + ( N (..) + , Vector (..) + , Operation (..) + , apply + , compose + , TransformedPair (..) + , transform + ) where + +data N = Z | S N deriving (Eq, Show) + +data Vector :: * -> N -> * where + EmptyV :: Vector a Z + ConsV :: a -> Vector a n -> Vector a (S n) + +data Operation :: * -> N -> N -> * where + EmptyOp :: Operation a Z Z + RetainOp :: Operation a n m -> Operation a (S n) (S m) + InsertOp :: a -> Operation a n m -> Operation a n (S m) + DeleteOp :: Operation a n m -> Operation a (S n) m + +apply :: Operation a n m -> Vector a n -> Vector a m +apply EmptyOp EmptyV = EmptyV +apply (RetainOp o') (ConsV x xs) = ConsV x (apply o' xs) +apply (InsertOp x o') xs = ConsV x (apply o' xs) +apply (DeleteOp o') (ConsV _ xs) = apply o' xs +apply _ _ = error "not possible!" + +addDeleteOp :: Operation a n m -> Operation a (S n) m +addDeleteOp (InsertOp x o') = InsertOp x (addDeleteOp o') +addDeleteOp o = DeleteOp o + +compose :: Operation a n m -> Operation a m k -> Operation a n k +compose EmptyOp EmptyOp = EmptyOp +compose (DeleteOp a') b = addDeleteOp (compose a' b) +compose a (InsertOp x b') = InsertOp x (compose a b') +compose (RetainOp a') (RetainOp b') = RetainOp (compose a' b') +compose (RetainOp a') (DeleteOp b') = addDeleteOp (compose a' b') +compose (InsertOp x a') (RetainOp b') = InsertOp x (compose a' b') +compose (InsertOp _ a') (DeleteOp b') = compose a' b' +compose _ _ = error "not possible!" + +data TransformedPair :: * -> N -> N -> * where + TP :: Operation a n k -> Operation a m k -> TransformedPair a n m + +transform :: Operation a n m -> Operation a n k -> TransformedPair a k m +transform EmptyOp EmptyOp = TP EmptyOp EmptyOp +transform (InsertOp x a') b = case transform a' b of TP at bt -> TP (InsertOp x at) (RetainOp bt) +transform a (InsertOp x b') = case transform a b' of TP at bt -> TP (RetainOp at) (InsertOp x bt) +transform (RetainOp a') (RetainOp b') = case transform a' b' of TP at bt -> TP (RetainOp at) (RetainOp bt) +transform (DeleteOp a') (DeleteOp b') = transform a' b' +transform (RetainOp a') (DeleteOp b') = case transform a' b' of TP at bt -> TP at (addDeleteOp bt) +transform (DeleteOp a') (RetainOp b') = case transform a' b' of TP at bt -> TP (addDeleteOp at) bt +transform _ _ = error "not possible!" diff --git a/src/Control/OperationalTransformation/Properties.hs b/src/Control/OperationalTransformation/Properties.hs --- a/src/Control/OperationalTransformation/Properties.hs +++ b/src/Control/OperationalTransformation/Properties.hs @@ -1,12 +1,15 @@ module Control.OperationalTransformation.Properties ( prop_compose_apply , prop_transform_apply + , prop_transform_compose + , prop_transform_compose_compat_l + , prop_transform_compose_compat_r ) where import Control.OperationalTransformation import Test.QuickCheck hiding (Result, reason) import Test.QuickCheck.Property -import Control.Monad (liftM2, liftM3) +import Control.Applicative ((<$>), (<*>)) (==?) :: (Eq a, Show a) => a -> a -> Result a ==? b | a == b = succeeded @@ -20,26 +23,74 @@ -- and /d/ is the initial document. prop_compose_apply :: (OTSystem doc op, OTComposableOperation op, Arbitrary doc, Show doc, Eq doc) => (doc -> Gen op) -> Property -prop_compose_apply genOperation = do +prop_compose_apply genOperation = property $ do doc <- arbitrary a <- genOperation doc - eitherProperty (apply a doc) $ \doc' -> do + return $ eitherProperty (apply a doc) $ \doc' -> property $ do b <- genOperation doc' - eitherProperty (apply b doc') $ \doc'' -> do - eitherProperty (compose a b) $ \ab -> do - property $ Right doc'' ==? apply ab doc + return $ eitherProperty ((,) <$> apply b doc' <*> compose a b) $ \(doc'', ab) -> + property $ Right doc'' ==? apply ab doc --- | @b'(a(d)) = b'(a(d))@ where /a/ and /b/ are random operations, /d/ is the +-- | @b'(a(d)) = a'(b(d))@ where /a/ and /b/ are random operations, /d/ is the -- initial document and @(a', b') = transform(a, b)@. prop_transform_apply :: (OTSystem doc op, Arbitrary doc, Show doc, Eq doc) => (doc -> Gen op) -> Property -prop_transform_apply genOperation = do +prop_transform_apply genOperation = property $ do doc <- arbitrary a <- genOperation doc b <- genOperation doc - let res1 = liftM3 (,,) (apply a doc) (apply b doc) (transform a b) - eitherProperty res1 $ \(doca, docb, (a', b')) -> do - let res2 = liftM2 (,) (apply b' doca) (apply a' docb) - eitherProperty res2 $ \(docab', docba') -> + let res1 = (,,) <$> apply a doc <*> apply b doc <*> transform a b + return $ eitherProperty res1 $ \(doca, docb, (a', b')) -> + let res2 = (,) <$> apply b' doca <*> apply a' docb + in eitherProperty res2 $ \(docab', docba') -> property $ docab' ==? docba' + +-- | @b' ∘ a = a' ∘ b@ where /a/ and /b/ are random operations and +-- @(a', b') = transform(a, b)@. Note that this is a stronger property than +-- prop_transform_apply, because prop_transform_compose and +-- prop_compose_apply imply prop_transform_apply. +prop_transform_compose :: (OTSystem doc op, OTComposableOperation op, Arbitrary doc, Show op, Eq op) + => (doc -> Gen op) + -> Property +prop_transform_compose genOperation = property $ do + doc <- arbitrary + a <- genOperation doc + b <- genOperation doc + return $ eitherProperty (transform a b) $ \(a', b') -> + eitherProperty ((,) <$> compose a b' <*> compose b a') $ \(ab', ba') -> + property $ ab' ==? ba' + +-- | Transformation is compatible with composition on the left. That is, if we +-- have two consecutive operations /a/ and /b/ and a concurrent operation /c/, +-- then it doesn't make a difference whether we transform /c/ against /a/ and +-- then against /b/ or transform /c/ against the composition of /a/ and /b/. +-- In other terms, @c'_1 = c'_2@ where @(_, c'_1) = transform(b ∘ a, c)@, +-- @(_, c') = transform(a, c)@ and @(_, c'_2) = transform(b, c')@. +prop_transform_compose_compat_l :: (OTSystem doc op, OTComposableOperation op, Arbitrary doc, Show op, Eq op) + => (doc -> Gen op) + -> Property +prop_transform_compose_compat_l genOperation = property $ do + doc <- arbitrary + a <- genOperation doc + c <- genOperation doc + return $ eitherProperty (apply a doc) $ \(doc') -> property $ do + b <- genOperation doc' + let res = (,) <$> (snd <$> (compose a b >>= flip transform c)) + <*> (snd <$> (transform a c >>= transform b . snd)) + return $ eitherProperty res $ \(c'_1, c'_2) -> + property $ c'_1 ==? c'_2 + +-- | Transformation is compatible with composition on the /right/. +prop_transform_compose_compat_r :: (OTSystem doc op, OTComposableOperation op, Arbitrary doc, Show op, Eq op) + => (doc -> Gen op) + -> Property +prop_transform_compose_compat_r genOperation = property $ do + doc <- arbitrary + a <- genOperation doc + c <- genOperation doc + return $ eitherProperty (apply a doc) $ \(doc') -> property $ do + b <- genOperation doc' + let res = (,) <$> (fst <$> (compose a b >>= transform c)) + <*> (fst <$> (transform c a >>= flip transform b . fst)) + return $ eitherProperty res $ \(c'_1, c'_2) -> property $ c'_1 ==? c'_2 diff --git a/src/Control/OperationalTransformation/Text.hs b/src/Control/OperationalTransformation/Text.hs --- a/src/Control/OperationalTransformation/Text.hs +++ b/src/Control/OperationalTransformation/Text.hs @@ -17,7 +17,6 @@ import Data.Monoid (mappend) import Data.Aeson (Value (..), FromJSON (..), ToJSON (..), (.=), object, (.:)) import Data.Binary (Binary (..), putWord8, getWord8) -import Data.Attoparsec.Number (Number (..)) import Data.Typeable (Typeable) import Data.Text (pack, unpack) import Control.Applicative ((<$>), (<*>)) @@ -41,13 +40,17 @@ _ -> Delete <$> get instance ToJSON Action where - toJSON (Retain n) = Number $ I (toInteger n) + toJSON (Retain n) = Number $ fromIntegral n toJSON (Insert t) = String t - toJSON (Delete n) = Number $ I (toInteger (-n)) + toJSON (Delete n) = Number $ fromIntegral (-n) instance FromJSON Action where - parseJSON (Number (I n)) | n > 0 = return $ Retain (fromInteger n) - | n < 0 = return $ Delete (fromInteger (-n)) + parseJSON (Number x) = do + n <- parseJSON (Number x) + case compare n 0 of + GT -> return $ Retain (fromInteger n) + LT -> return $ Delete (fromInteger (-n)) + EQ -> fail "integer must not be zero" parseJSON (String i) = return $ Insert i parseJSON _ = fail "expected a non-zero integer or a string" @@ -55,13 +58,14 @@ -- that change the document at the current cursor position or advance the -- cursor. After applying all actions, the cursor must be at the end of the -- document. -newtype TextOperation = TextOperation [Action] deriving (Eq, Read, Show, Binary, Typeable, FromJSON, ToJSON) +newtype TextOperation = TextOperation [Action] deriving (Read, Show, Binary, Typeable, FromJSON, ToJSON) addRetain :: Int -> [Action] -> [Action] addRetain n (Retain m : xs) = Retain (n+m) : xs addRetain n xs = Retain n : xs addInsert :: T.Text -> [Action] -> [Action] +addInsert s (Delete d : xs) = Delete d : addInsert s xs addInsert s (Insert t : xs) = Insert (t `mappend` s) : xs addInsert s xs = Insert s : xs @@ -69,6 +73,28 @@ addDelete n (Delete m : xs) = Delete (n+m) : xs addDelete n xs = Delete n : xs +-- | Merges actions, removes empty ops and makes insert ops come before delete +-- ops. Propertys: +-- +-- * Idempotence: @canonicalize op = canonicalize (canonicalize op)@ +-- +-- * Preserves the effect under apply: @apply op doc = apply (canonicalize op) doc@ +canonicalize :: TextOperation -> TextOperation +canonicalize (TextOperation ops) = TextOperation $ reverse $ loop [] $ reverse ops + where + loop as [] = as + loop as (Retain n : bs) | n <= 0 = loop as bs + | True = loop (addRetain n as) bs + loop as (Insert i : bs) | i == "" = loop as bs + | True = loop (addInsert i as) bs + loop as (Delete d : bs) | d <= 0 = loop as bs + | True = loop (addDelete d as) bs + +instance Eq TextOperation where + a == b = opsa == opsb + where TextOperation opsa = canonicalize a + TextOperation opsb = canonicalize b + instance OTOperation TextOperation where transform (TextOperation o1) (TextOperation o2) = both (TextOperation . reverse) `fmap` loop o1 o2 [] [] where @@ -191,10 +217,10 @@ } deriving (Eq, Show, Read) instance ToJSON AugmentedTextOperation where - toJSON (AugmentedTextOperation cursor textOp) = object [ "meta" .= cursor, "operation" .= textOp ] + toJSON (AugmentedTextOperation cursor textOp) = object [ "cursor" .= cursor, "operation" .= textOp ] instance FromJSON AugmentedTextOperation where - parseJSON (Object o) = AugmentedTextOperation <$> o .: "meta" <*> o .: "operation" + parseJSON (Object o) = AugmentedTextOperation <$> o .: "cursor" <*> o .: "operation" parseJSON _ = fail "expected an object" instance OTOperation AugmentedTextOperation where