ot 0.1.2.2 → 0.2.0.0

raw patch · 7 files changed

+182/−99 lines, 7 filesdep +eitherdep +ghcdep +mtldep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: either, ghc, mtl

Dependency ranges changed: binary

API changes (from Hackage documentation)

Files

• ot.cabal +7/−4
• src/Control/OperationalTransformation.hs +25/−0
• src/Control/OperationalTransformation/Selection.hs +93/−0
• src/Control/OperationalTransformation/Server.hs +25/−20
• src/Control/OperationalTransformation/Text.hs +18/−65
• test/Main.hs +14/−0
• test/TestSuite.hs +0/−10

@@ -1,5 +1,5 @@ Name:                ot-Version:             0.1.2.2+Version:             0.2.0.0 Synopsis:            Real-time collaborative editing with Operational Transformation -- A longer description of the package. -- Description:         @@ -19,13 +19,16 @@ Library   Ghc-options:         -Wall   Hs-source-dirs:      src-  Exposed-modules:     Control.OperationalTransformation, Control.OperationalTransformation.List, Control.OperationalTransformation.Text, Control.OperationalTransformation.Properties, Control.OperationalTransformation.Client, Control.OperationalTransformation.Server+  Exposed-modules:     Control.OperationalTransformation, Control.OperationalTransformation.List, Control.OperationalTransformation.Text, Control.OperationalTransformation.Selection, Control.OperationalTransformation.Properties, Control.OperationalTransformation.Client, Control.OperationalTransformation.Server   Build-depends:       base >= 4 && < 5,                        text >= 1.0 && < 1.3,                        aeson >= 0.7 && < 0.9,                        attoparsec >= 0.10.1.1 && < 1,                        QuickCheck >= 2.7 && < 2.8,-                       binary >= 0.6.0.0 && < 0.8+                       binary >= 0.5.1.1 && < 0.8,+                       either >= 4.1.2 && < 5,+                       mtl >= 2.1.3.1 && < 3,+                       ghc    -- Modules not exported by this package.   -- Other-modules:       @@ -34,7 +37,7 @@   Ghc-options:         -Wall -rtsopts   Hs-source-dirs:      test   type:                exitcode-stdio-1.0-  main-is:             TestSuite.hs+  main-is:             Main.hs   Build-depends:       ot,                        QuickCheck,                        HUnit,

@@ -3,6 +3,7 @@ module Control.OperationalTransformation   ( OTOperation (..)   , OTComposableOperation (..)+  , OTCursor (..)   , OTSystem (..)   ) where @@ -38,11 +39,35 @@         (os', ps'') <- transformList2 os ps'         return (o':os', ps'') +-- | Cursor position+class OTCursor cursor op where+  updateCursor :: op -> cursor -> cursor++ instance (OTOperation op) => OTComposableOperation [op] where   compose a b = return $ a ++ b  instance (OTSystem doc op) => OTSystem doc [op] where   apply = flip $ foldM $ flip apply+++instance OTCursor () op where+  updateCursor _ _ = ()++instance OTCursor cursor op => OTCursor [cursor] op where+  updateCursor op = map (updateCursor op)++instance (OTCursor a op, OTCursor b op) => OTCursor (a, b) op where+  updateCursor op (a, b) = (updateCursor op a, updateCursor op b)++instance (OTCursor a op, OTCursor b op, OTCursor c op) => OTCursor (a, b, c) op where+  updateCursor op (a, b, c) = (updateCursor op a, updateCursor op b, updateCursor op c)++instance (OTCursor a op, OTCursor b op, OTCursor c op, OTCursor d op) => OTCursor (a, b, c, d) op where+  updateCursor op (a, b, c, d) = (updateCursor op a, updateCursor op b, updateCursor op c, updateCursor op d)++instance (OTCursor a op, OTCursor b op, OTCursor c op, OTCursor d op, OTCursor e op) => OTCursor (a, b, c, d, e) op where+  updateCursor op (a, b, c, d, e) = (updateCursor op a, updateCursor op b, updateCursor op c, updateCursor op d, updateCursor op e)   instance (OTOperation a, OTOperation b) => OTOperation (a, b) where

@@ -0,0 +1,93 @@+{-# LANGUAGE CPP, TypeFamilies, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++module Control.OperationalTransformation.Selection+  ( Range (..)+  , Selection (..)+  , createCursor+  , size+  , somethingSelected+  ) where++import Control.OperationalTransformation+import Control.OperationalTransformation.Text+import Data.Aeson+import Control.Applicative+import Data.Monoid+import Data.List (sort)+import qualified Data.Text as T+#if MIN_VERSION_ghc(7,8,0)+import GHC.Exts (IsList (..))+#endif++-- | Range has `anchor` and `head` properties, which are zero-based indices into+-- the document. The `anchor` is the side of the selection that stays fixed,+-- `head` is the side of the selection where the cursor is. When both are+-- equal, the range represents a cursor.+data Range = Range { rangeAnchor :: !Int, rangeHead :: !Int }+  deriving (Show, Read, Eq, Ord)++instance ToJSON Range where+  toJSON (Range a h) = object [ "anchor" .= a, "head" .= h ]++instance FromJSON Range where+  parseJSON (Object o) = Range <$> o .: "anchor" <*> o .: "head"+  parseJSON _ = fail "expected an object"++instance OTCursor Range TextOperation where+  updateCursor (TextOperation actions) (Range a h) = Range a' h'+    where+      a' = updateComponent a+      h' = if a == h then a' else updateComponent h+      updateComponent c = loop c c actions+      loop :: Int -> Int -> [Action] -> Int+      loop oldIndex newIndex as+        | oldIndex < 0 = newIndex+        | otherwise =+          case as of+            (op:ops) -> case op of+              Retain r -> loop (oldIndex-r) newIndex ops+              Insert i -> loop oldIndex (newIndex + T.length i) ops+              Delete d -> loop (oldIndex-d) (newIndex - min oldIndex d) ops+            _ -> newIndex -- matching on `[]` gives a non-exhaustive pattern+                          -- match warning for some reason++-- | A selection consists of a list of ranges. Each range may represent a+-- selected part of the document or a cursor in the document.+newtype Selection = Selection { ranges :: [Range] }+  deriving (Monoid, Show, Read)++instance OTCursor Selection TextOperation where+  updateCursor op = Selection . updateCursor op . ranges++instance Eq Selection where+  Selection rs1 == Selection rs2 = sort rs1 == sort rs2++instance Ord Selection where+  Selection rs1 `compare` Selection rs2 = sort rs1 `compare` sort rs2++instance ToJSON Selection where+  toJSON (Selection rs) = object [ "ranges" .= rs ]++instance FromJSON Selection where+  parseJSON (Object o) = Selection <$> o .: "ranges"+  parseJSON _ = fail "expected an object"++#if MIN_VERSION_ghc(7,8,0)+instance IsList Selection where+  type Item Selection = Range+  fromList = Selection+  toList = ranges+#endif++-- | Create a selection that represents a cursor.+createCursor :: Int -> Selection+createCursor i = Selection [Range i i]++-- | Does the selection contain any characters?+somethingSelected :: Selection -> Bool+somethingSelected = any (\r -> rangeAnchor r /= rangeHead r) . ranges++-- | Number of selected characters+size :: Selection -> Int+size = sum . map (\r -> abs (rangeAnchor r - rangeHead r)) . ranges

@@ -6,7 +6,8 @@   ) where  import Control.OperationalTransformation-import Control.Monad (foldM)+import Control.Monad.Trans.Either+import Control.Monad.Identity  type Revision = Integer @@ -18,27 +19,31 @@ initialServerState doc = ServerState 0 doc []  -- | Handles incoming operations.-applyOperation :: (OTSystem doc op)+applyOperation :: (OTSystem doc op, OTCursor cursor op)                => ServerState doc op                -> Revision                -- ^ The latest operation that the client has received from the server when it sent the operation.                -> op                -- ^ The operation received from the client.-               -> Either String (op, ServerState doc op)-               -- ^ The operation to broadcast to all connected clients-               -- (except the client which has created the operation; that-               -- client must be sent an acknowledgement) and the new state-               -- (or an error).-applyOperation (ServerState rev doc ops) oprev op = do-  concurrentOps <- if oprev > rev || rev - oprev > fromIntegral (length ops)-    then Left "unknown revision number"-    else Right $ take (fromInteger $ rev - oprev) ops-  op' <- foldM transformFst op (reverse concurrentOps)-  doc' <- case apply op' doc of-    Left err -> Left $ "apply failed: " ++ err-    Right d -> Right d-  return $ (op', ServerState (rev+1) doc' (op':ops))-  where-    transformFst a b = case transform a b of-      Left err -> Left $ "transform failed: " ++ err-      Right (a', _) -> Right a'+               -> cursor+               -- ^ The clients cursor position after the operation. (Use @()@+               -- if not needed.)+               -> Either String (op, cursor, ServerState doc op)+               -- ^ The operation and the cursor to broadcast to all+               -- connected clients  (except the client which has created the+               -- operation; that client must be sent an acknowledgement) and+               -- the new state (or an error).+applyOperation (ServerState rev doc ops) oprev op cursor =+  runIdentity $ runEitherT $ do+    concurrentOps <- if oprev > rev || rev - oprev > fromIntegral (length ops)+      then fail "unknown revision number"+      else return $ take (fromInteger $ rev - oprev) ops+    (op', cursor') <- foldM transformFst (op, cursor) (reverse concurrentOps)+    doc' <- case apply op' doc of+      Left err -> fail $ "apply failed: " ++ err+      Right d -> return d+    return $ (op', cursor', ServerState (rev+1) doc' (op':ops))+    where+      transformFst (a, curs) b = case transform a b of+        Left err -> fail $ "transform failed: " ++ err+        Right (a', _) -> return (a', updateCursor op curs)

@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies #-}  module Control.OperationalTransformation.Text   (@@ -6,21 +8,19 @@     Action (..)   , TextOperation (..)   , invertOperation-    -- * Text operations augmented with cursor information-  , Cursor (..)-  , updateCursor-  , AugmentedTextOperation (..)   ) where  import Control.OperationalTransformation import qualified Data.Text as T import Data.Monoid (mappend)-import Data.Aeson (Value (..), FromJSON (..), ToJSON (..), (.=), object, (.:))+import Data.Aeson (Value (..), FromJSON (..), ToJSON (..)) import Data.Binary (Binary (..), putWord8, getWord8) import Data.Typeable (Typeable) import Data.Text (pack, unpack)-import Control.Applicative ((<$>), (<*>))-+import Control.Applicative ((<$>))+#if MIN_VERSION_ghc(7,8,0)+import GHC.Exts (IsList (..))+#endif  -- | An action changes the text at the current position or advances the cursor. data Action = Retain !Int    -- ^ Skip the next n characters.@@ -60,6 +60,13 @@ -- document. newtype TextOperation = TextOperation [Action] deriving (Read, Show, Binary, Typeable, FromJSON, ToJSON) +#if MIN_VERSION_ghc(7,8,0)+instance IsList TextOperation where+  type Item TextOperation = Action+  fromList = TextOperation+  toList (TextOperation as) = as+#endif+ addRetain :: Int -> [Action] -> [Action] addRetain n (Retain m : xs) = Retain (n+m) : xs addRetain n xs = Retain n : xs@@ -74,7 +81,7 @@ addDelete n xs = Delete n : xs  -- | Merges actions, removes empty ops and makes insert ops come before delete--- ops. Propertys:+-- ops. Properties: -- --     * Idempotence: @canonicalize op = canonicalize (canonicalize op)@ --@@ -169,8 +176,8 @@       loop _ _ _ = Left "operation can't be applied to the document: text is longer than the operation"  -- | Computes the inverse of an operation. Useful for implementing undo.-invertOperation :: TextOperation               -- ^ An operation.-                -> T.Text                      -- ^ Document before the operation was applied.+invertOperation :: TextOperation               -- ^ An operation+                -> T.Text                      -- ^ Document to apply the operation to                 -> Either String TextOperation invertOperation (TextOperation actions) doc = loop actions doc []   where@@ -181,57 +188,3 @@                     in loop ops after (Insert before : inv)     loop [] "" inv = Right . TextOperation . reverse $ inv     loop [] _ _ = Left "invert failed: text is longer than the operation"---- | A cursor has a 'cursorPosition' and a 'cursorSelectionEnd'. Both are--- zero-based indexes into the document. When nothing is selected,--- 'cursorSelectionEnd' is equal to 'cursorPosition'. When there is a selection,--- 'cursorPosition' is always the side of the selection that would move if you--- pressed an arrow key.-data Cursor = Cursor { cursorPosition, cursorSelectionEnd :: Int } deriving (Eq, Show, Read)---- | Update cursor with respect to an operation.-updateCursor :: Cursor -> TextOperation -> Cursor-updateCursor (Cursor p s) (TextOperation actions) = Cursor transformedP transformedS-  where-    transformedP = transformComponent p-    transformedS = if p == s then transformedP else transformComponent s-    transformComponent c = loop c c actions-    loop oldIndex newIndex _ | oldIndex < 0 = newIndex-    loop _ newIndex [] = newIndex-    loop oldIndex newIndex (op:ops) = case op of-      Retain r -> loop (oldIndex-r) newIndex ops-      Insert i -> loop oldIndex (newIndex + T.length i) ops-      Delete d -> loop (oldIndex-d) (newIndex - min oldIndex d) ops--instance ToJSON Cursor where-  toJSON (Cursor p s) = object [ "position" .= p, "selectionEnd" .= s ]--instance FromJSON Cursor where-  parseJSON (Object o) = Cursor <$> o .: "position" <*> o .: "selectionEnd"-  parseJSON _ = fail "expected an object"---- | An operation bundled with the cursor position after the operation.-data AugmentedTextOperation = AugmentedTextOperation-  { augmentedCursor    :: Cursor-  , augmentedOperation :: TextOperation-  } deriving (Eq, Show, Read)--instance ToJSON AugmentedTextOperation where-  toJSON (AugmentedTextOperation cursor textOp) = object [ "cursor" .= cursor, "operation" .= textOp ]--instance FromJSON AugmentedTextOperation where-  parseJSON (Object o) = AugmentedTextOperation <$> o .: "cursor" <*> o .: "operation"-  parseJSON _ = fail "expected an object"--instance OTOperation AugmentedTextOperation where-  transform (AugmentedTextOperation cursorA opA) (AugmentedTextOperation cursorB opB) = do-    (opA', opB') <- transform opA opB-    return ( AugmentedTextOperation (updateCursor cursorA opB') opA'-           , AugmentedTextOperation (updateCursor cursorB opA') opB'-           )--instance OTComposableOperation AugmentedTextOperation where-  compose (AugmentedTextOperation _ a) (AugmentedTextOperation cursor b) = AugmentedTextOperation cursor <$> compose a b--instance (OTSystem doc TextOperation) => OTSystem doc AugmentedTextOperation where-  apply (AugmentedTextOperation _ textOp) = apply textOp

@@ -0,0 +1,14 @@+module Main (main) where++import Test.Framework++import qualified Control.OperationalTransformation.Text.Tests+import qualified Control.OperationalTransformation.Selection.Tests+import qualified Control.OperationalTransformation.ClientServerTests++main :: IO ()+main = defaultMain+  [ Control.OperationalTransformation.Text.Tests.tests+  , Control.OperationalTransformation.Selection.Tests.tests+  , Control.OperationalTransformation.ClientServerTests.tests+  ]

@@ -1,10 +0,0 @@-import Test.Framework--import qualified Control.OperationalTransformation.Text.Tests-import qualified Control.OperationalTransformation.ClientServerTests--main :: IO ()-main = defaultMain-  [ Control.OperationalTransformation.Text.Tests.tests-  , Control.OperationalTransformation.ClientServerTests.tests-  ]