Skip to content

Instantly share code, notes, and snippets.

@gatlin
Last active January 24, 2020 17:03
Show Gist options
  • Save gatlin/1bf02fa50e02a481f7142dd87fe2711f to your computer and use it in GitHub Desktop.
Save gatlin/1bf02fa50e02a481f7142dd87fe2711f to your computer and use it in GitHub Desktop.
{- |
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'
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment