ot 0.1.2 → 0.1.2.1

raw patch · 5 files changed

+163/−37 lines, 5 filesdep ~QuickCheckdep ~aesondep ~binaryPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: QuickCheck, aeson, binary, test-framework, test-framework-hunit, test-framework-quickcheck2, text

API changes (from Hackage documentation)

Files

• ot.cabal +9/−16
• src/Control/OperationalTransformation.hs +0/−1
• src/Control/OperationalTransformation/List.hs +57/−0
• src/Control/OperationalTransformation/Properties.hs +63/−12
• src/Control/OperationalTransformation/Text.hs +34/−8

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

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

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

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

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