ot.hs

{- |
Operational transformation in Haskell using (co)free (co)monads.
-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.List (splitAt)
import Control.Monad
import Control.Monad.Free
import Control.Comonad
import Control.Comonad.Cofree
import Data.Monoid
import Data.Ord

-- | For our purposes a document is simply a 'String'.
type Document = String

-- | The language of document operations
data OperationGrammar k
    = Insert String k
    | Delete Int k
    | Retain Int k
    deriving (Show,Functor)

-- | Operations to be performed on a document
type Operation = Free OperationGrammar ()

-- | Operations may be composed!
instance Monoid (Free OperationGrammar ()) where
    mempty = return ()
    mappend = (>>)

-- | Transform two operations into a pair of rebased operations
xform :: Operation -> Operation -> (Operation, Operation)
-- Did we get nothing to start with?

xform a b = go a b (return (), return ()) where

    -- Finished?
    go (Pure ()) (Pure()) result = result

    -- Handle any insertions first
    go (Free (Insert s k)) b (a', b') =
        go k b (a' <> insert s ,  b' <> retain (length s))
    go a (Free (Insert s k)) (a', b') =
        go a k (a' <> retain (length s) , b' <> insert s)

    -- Four more cases!
    go a b (a', b') = case (a, b) of
        -- Retain / Retain
        (Free (Retain n1 k1), Free (Retain n2 k2)) ->
            let ops minl = (a' <> retain minl, b' <> retain minl)
            in  case compare n1 n2 of
                EQ -> go k1 k2 $ ops n2
                GT -> go (Free (Retain (n1 - n2) k1)) k2 $ ops n2
                LT -> go k1 (Free (Retain (n2 - n1) k2)) $ ops n1

        -- Delete / Delete
        (Free (Delete n1 k1), Free (Delete n2 k2)) ->
            case compare n1 n2 of
                EQ -> go k1 k2 (a', b')
                GT -> go (Free (Delete (n1 - n2) k1)) k2 (a', b')
                LT -> go k1 (Free (Delete (n2 - n1) k2)) (a', b')

        -- Delete / Retain
        (Free (Delete n1 k1), Free (Retain n2 k2)) ->
            let ops minl = (a' >> delete minl, b')
            in  case compare n1 n2 of
                EQ -> go k1 k2 $ ops n2
                GT -> go (Free (Delete (n1 - n2) k1)) k2 $ ops n2
                LT -> go k1 (Free (Retain (n2 - n1) k2)) $ ops n1

        -- Retain / Delete
        (Free (Retain n1 k1), Free (Delete n2 k2)) ->
            let ops minl = (a', b' >> delete minl)
            in  case compare n1 n2 of
                EQ -> go k1 k2 $ ops n2
                GT -> go (Free (Retain (n1 - n2) k1)) k2 $ ops n2
                LT -> go k1 (Free (Delete (n2 - n1) k2)) $ ops n1

-- ** Document operations.

insert :: String -> Operation
insert str = liftF $ Insert str ()

delete :: Int -> Operation
delete str = liftF $ Delete str ()

retain :: Int -> Operation
retain n = liftF $ Retain n ()

data CursorF k = CursorF
    { insertH :: String -> k
    , deleteH :: Int -> k
    , retainH :: Int -> k
    } deriving (Functor)

-- | Where 'Op'erations happen
type Cursor = Cofree CursorF

-- | A cursor pointing to a specific character in a 'Document'
type Editor = Cursor (Int, Document)

-- ** Handlers for document operations.

coInsert :: (Int, Document) -> String -> (Int, Document)
coInsert (idx, doc) str = (idx', doc') where
    idx' = idx + length str
    doc' = pre ++ str ++ post
    (pre,post) = splitAt idx doc

coDelete :: (Int, Document) -> Int -> (Int, Document)
coDelete (idx, doc) n = (idx, doc') where
    doc' = pre ++ (drop n post)
    (pre,post) = splitAt idx doc

coRetain :: (Int, Document) -> Int -> (Int, Document)
coRetain (idx, doc) n = (idx+n,doc)

newEditor :: (Int, Document) -> Editor
newEditor start = coiter next start where
    next w = CursorF
                (coInsert w)
                (coDelete w)
                (coRetain w)

-- | My shitty adjunction representation stolen from David Laing
class (Functor f, Functor g) => Run f g where
    run :: (a -> b -> r) -> f a -> g b -> r

instance Run f g => Run (Cofree f) (Free g) where
    run p (a :<  _) (Pure x) = p a x
    run p (_ :< fs) (Free gs) = run (run p) fs gs

instance Run CursorF OperationGrammar where
    run f (CursorF i _ _) (Insert s k) = f (i s) k
    run f (CursorF _ d _) (Delete s k) = f (d s) k
    run f (CursorF _ _ r) (Retain n k)      = f (r n) k

-- | Construct an initial document using the supplied operations
buildDocument :: Operation -> (Int, Document)
buildDocument = edit ""

-- | Edit an existing document with the supplied operations
edit :: Document -> Operation -> (Int, Document)
edit doc ops = run const (newEditor (0,doc)) ops

doc :: Document
doc = "lorem ipsum"

-- first, concurrent with op2
op1 :: Operation
op1 = do
    retain 11
    insert " dolor"

-- first, concurrent with op1
op2 :: Operation
op2 = do
    delete 6
    retain 5

-- second, follows op1
op3 :: Operation
op3 = do
    retain 17
    insert "!"

doc_test :: IO ()
doc_test = do
    let (_, doc_op1) = edit doc op1
    let (_, doc_op2) = edit doc op2
    let (op2', op1') = xform op2 op1
    putStrLn . show $ edit doc_op1 op2'
    putStrLn . show $ edit doc_op2 op1'

go_doc :: Document
go_doc = "go"

a, b :: Operation
a = do
    retain 2
    insert "t"

b = do
    retain 2
    insert "a"

go_test :: IO ()
go_test = do
    let (b', a') = xform b a
    let (_, go_a) = edit go_doc a
    let (_, go_b) = edit go_doc b

    putStrLn $ "a' = " ++ show a'
    putStrLn $ "b' = " ++ show b'
    putStrLn $ "b' <> a = " ++ (show $ b' <> a)
    putStrLn $ "a' <> b = " ++ (show $ a' <> b)
    putStrLn . show $ edit go_a b'
    putStrLn . show $ edit go_b a'