packages feed

crjdt-haskell (empty) → 0.1.0.0

raw patch · 13 files changed

+1140/−0 lines, 13 filesdep +basedep +containersdep +crjdt-haskellsetup-changed

Dependencies added: base, containers, crjdt-haskell, free, hedgehog, hspec, mtl, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Amar Potghan (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,54 @@+[![Build Status](https://travis-ci.org/amarpotghan/crjdt-haskell.svg?branch=master)](https://travis-ci.org/amarpotghan/haskell-crjdt)++# A Conflict-Free Replicated JSON Datatype for Haskell++*crjdt-haskell* provides high level interface to CRDT which is formalised in the [paper](https://arxiv.org/pdf/1608.03960v1.pdf) by Martin Kleppmann and Alastair R. Beresford.++## Example++```haskell++{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.Crjdt as C++-- Original state+original :: Command ()+original = (doc .> key "key") =: "A"++-- First replica updates doc["key"] to "B"+replica1 :: Command ()+replica1 = do+  original+  (doc .> key "key") =: "B"++-- Second replica updates doc["key"] to "C"+replica2 :: Command ()+replica2 = do+  original+  (doc .> key "key") =: "C"++main :: IO ()+main = do+  -- Sync first and second replica+  (r1, r2) <- sync (1, replica1) (2, replica2)++  let replica1' = execEval 1 r1+      replica2' = execEval 2 r2++  -- Both replicas converge to: {"key": {"B", "C"}}+  print (document replica1' == document replica2') -- True++```++## Future work++* Aeson support+* Simplify API as described in [second version](https://arxiv.org/abs/1608.03960) of the paper++## LICENSE++Copyright © 2017 Amar Potghan++Distributed under BSD License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ crjdt-haskell.cabal view
@@ -0,0 +1,49 @@+name:          crjdt-haskell+version:       0.1.0.0+synopsis:      A Conflict-Free Replicated JSON Datatype for Haskell+description:   A Conflict-Free Replicated JSON Datatype for Haskell+homepage:      https://github.com/amarpotghan/crjdt-haskell#readme+license:       BSD3+license-file:  LICENSE+author:        Amar Potghan+maintainer:    amarpotghan@gmail.com+copyright:     2017 Amar Potghan+category:      Data+build-type:    Simple+cabal-version: >=1.10++extra-source-files:  README.md++library+  hs-source-dirs:      src+  exposed-modules:     Data.Crjdt+                     , Data.Crjdt.Context+                     , Data.Crjdt.Types+                     , Data.Crjdt.Eval+                     , Data.Crjdt.Internal+                     , Data.Crjdt.Internal.Core+  build-depends:       base >= 4.7 && < 5+                     , text >= 0.11.1.0 && < 1.3+                     , containers >= 0.5.0.0  && < 0.6+                     , mtl >= 2.2.1 && < 2.3+                     , free >= 4.6.1 && < 5+  default-language:    Haskell2010++test-suite crjdt-haskell-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , crjdt-haskell+                     , hspec+                     , containers >= 0.5.0.0  && < 0.6+                     , mtl+                     , hedgehog >= 0.1+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  other-modules: Data.CrjdtSpec+               , Data.FigureSpec+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/amarpotghan/crjdt-haskell
+ src/Data/Crjdt.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+-- |This module exports all necessarry data types and functions for+-- expressing and executing commands which allow modifying and+-- querying the state of JSON in local replica++module Data.Crjdt+  (+  -- * Expressions+    iter+  , next+  , key+  , doc+  , var++  -- * Commands+  , Command(..)+  , yield+  , keys+  , values+  , insert+  , delete+  , bind+  , (-<)+  , assign+  , (=:)++  -- * Values+  , string+  , emptyMap+  , emptyList++  -- * Evaluation and Execution+  , Eval.eval+  , Eval.execute++  -- * Re-exports+  , Void+  , (.>)+  , (&)++  -- * Others+  , sync+  , module Core+  ) where++import Data.Text as T+import Data.Set (Set)+import Data.Void+import Data.Function+import Control.Exception (throwIO)+import Control.Monad.Free (liftF)++import Data.Crjdt.Context as Core+import Data.Crjdt.Types as Core++import qualified Data.Crjdt.Eval as Eval (execute, eval)+import Data.Crjdt.Eval as Core hiding (execute, eval)++import Data.Crjdt.Internal++(.>) :: b -> (b -> a) -> a+(.>) = (&)++infixl 4 .>++-- |'emptyMap' corresponds to {}.+emptyMap :: Val+emptyMap = EmptyObject++-- |'emptyList' corresponds to [].+emptyList :: Val+emptyList = EmptyArray++-- |Apply commands received from other replicas to current replica.+yield :: Command ()+yield = liftF (Yield ())++{-| String literal.++  @+    'doc' '.>' "planet" '.=' 'string' \"Earth\"+  @++-}+string :: Text -> Val+string = StringLit++{-| Starts iterating over the list.++  @+    do+     let planetList = 'doc' '.>' "planet" .> 'iter'+     insert \"Earth\" planetList+  @++-}+iter :: Expr -> Expr+iter = Iter++{-| Moves to the next element in the list.+-}+next :: Expr -> Expr+next = Next++{-| Get value of given key in given expression.+-}+key :: Key Void -> Expr -> Expr+key = flip GetKey++{-| The root of the JSON object.+-}+doc :: Expr+doc = Doc++-- |Variable.+var :: Text -> Expr+var = Var . Variable++-- |Insert a @Val@ in the list.+insert :: Val -> Expr -> Command ()+insert v e = liftF (InsertAfter e v ())++-- |Delete the list element.+delete :: Expr -> Command ()+delete e = liftF (Delete e ())++-- |Get all keys of object pointed by given 'Expr'.+keys :: Expr -> Command (Set (Key Void))+keys e = liftF (Keys e id)++-- |Get all values of object pointed by given 'Expr'.+values :: Expr -> Command [Val]+values e = liftF (Values e id)++-- |Assign value to the key pointed by given 'Expr'.+assign, (=:) :: Expr -> Val -> Command ()+assign e v = liftF (Assign e v ())+(=:) = assign++infixr 5 =:++-- |Let binding.+bind, (-<) :: Text -> Expr -> Command Expr+bind t e = liftF (Let t e id)+(-<) = bind++-----------------------------------------------------------------------------------------------+-- Utility functions++sync :: (ReplicaId, Command ()) -> (ReplicaId, Command ()) -> IO (Eval (), Eval ())+sync (rid1, first) (rid2, second) =+  let (rFirst, sFirst) = run rid1 (Eval.execute first)+      (rSecond, sSecond) = run rid2 (Eval.execute second)+      synced which replica = do+        Eval.execute which+        addReceivedOps (queue replica)+        Eval.execute yield+  in case (rFirst *> rSecond) of+    Right () -> pure $ (synced first sSecond, synced second sFirst)+    Left ex -> throwIO ex
+ src/Data/Crjdt/Context.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Crjdt.Context+  ( Context(..)+  , Cursor(..)+  , Operation(..)+  , Tag(..)+  , Mutation(..)+  , Document(..)+  , Branch(..)+  , RegDocument(..)+  , findChild+  , applyOp+  , getPresence+  , setPath+  , setFinalKey+  , lookupCtx+  , appendWith+  , docKey+  , stepNext+  ) where++import Data.Void+import Data.Foldable as Foldable (toList)+import Data.Maybe+import Data.Sequence (ViewL(..), viewl)+import qualified Data.Sequence as Seq+import Data.Map as M+import Data.Set as Set+import Control.Monad.State++import Data.Crjdt.Types+import Data.Crjdt.Internal.Core++data Tag+  = MapT+  | ListT+  | RegT+  deriving (Show, Eq, Ord)++data Context = Context+  { document :: Document Tag+  , variables :: M.Map Var Cursor+  , replicaId :: ReplicaId+  , replicaGlobal :: GlobalReplicaCounter+  , history :: Set Id+  , queue :: Seq.Seq Operation+  , received :: Seq.Seq Operation+  } deriving Show++data Cursor = Cursor+  { path :: Seq.Seq (Key Tag)+  , finalKey :: Key Void+  } deriving (Show, Eq)++docKey :: Key Tag+docKey = tagWith MapT DocKey++appendWith :: Tag -> Key Void -> Cursor -> Cursor+appendWith t k (Cursor p final) = Cursor (p `mappend` Seq.singleton (reTag t final)) k++-- Avoiding lens dependency for now+setFinalKey :: Key Void -> Cursor -> Cursor+setFinalKey fk c = c { finalKey = fk }++setPath :: Seq.Seq (Key Tag) -> Cursor -> Cursor+setPath newpath c = c { path = newpath }++-- still avoiding lens, but almost there :-)+findChild :: Key Tag -> Document Tag -> Maybe (Document Tag)+findChild t = ((M.lookup t . children) =<<) . branchOf++childGet :: Key Tag -> Document Tag -> Document Tag+childGet k = fromMaybe (choose (getTag k)) . findChild k+  where+    choose MapT = BranchDocument $ Branch mempty mempty mempty MapT+    choose ListT = BranchDocument $ Branch mempty mempty (M.singleton Head Tail) ListT+    choose RegT = LeafDocument mempty++lookupCtx :: Var -> Context -> Maybe Cursor+lookupCtx v = M.lookup v . variables++getPresence :: Key Void -> Document Tag -> Set Id+getPresence k =  fromMaybe mempty . ((M.lookup k . presence) =<<) . branchOf++next :: Key Void -> Document Tag -> Key Void+next (Key key) d = Key $ fromMaybe Tail $ next'+  where+    next' = branchOf d >>= ensureList >>= M.lookup key . keyOrder+    ensureList b@Branch{branchTag = ListT} = Just b+    ensureList _ = Nothing+next k _ = k++updatePresence :: Key Void -> Set Id -> Document tag -> Document tag+updatePresence key deps d = fromMaybe d . fmap (BranchDocument . newBranch) . branchOf $ d+  where newBranch b =+          if (Set.null deps)+          then b { presence = M.delete key (presence b) }+          else b { presence = M.insert key deps $ presence b }++branchOf :: Document tag -> Maybe (Branch tag)+branchOf (LeafDocument _) = Nothing+branchOf (BranchDocument b) = Just b++data Mutation+  = InsertMutation Val+  | DeleteMutation+  | AssignMutation Val+  deriving (Show, Eq)++data Operation = Operation+  { opId :: Id+  , opDeps :: Set.Set Id -- TODO:  version-vectors or dotted-version-vectors+  , opCur :: Cursor+  , opMutation :: Mutation+  } deriving (Eq, Show)++newtype RegDocument = RegDocument { registers :: M.Map Id Val } deriving (Show, Eq, Monoid)++data Branch tag = Branch+  { children :: Map (Key tag) (Document tag)+  , presence :: Map (Key Void) (Set Id)+  , keyOrder :: Map BasicKey BasicKey+  , branchTag :: tag+  } deriving (Eq, Show)++data Document tag+  = BranchDocument (Branch tag)+  | LeafDocument RegDocument+  deriving (Eq, Show)++clearElem :: Set Id -> Key Void -> State (Document Tag) (Set Id)+clearElem deps key = do+  presence <- clearAny deps key+  presence' <- getPresence key <$> get+  let newPresence = presence `mappend` presence' Set.\\ deps+  modify (updatePresence key newPresence)+  pure (newPresence)++clearAny :: Set Id -> Key Void -> State (Document Tag) (Set Id)+clearAny deps key = mconcat <$> traverse clearAll [MapT, ListT, RegT]+  where+    clearAll t = clear deps (reTag t key)++clear :: Set Id -> Key Tag -> State (Document Tag) (Set Id)+clear deps key = get >>= (clear' <*> findChild key)+  where+    clear' _ Nothing = pure mempty+    clear' d (Just (LeafDocument reg)) = put (addChild key (LeafDocument $ RegDocument c) d) *> pure (M.keysSet c)+      where c = M.filterWithKey (\k _ -> k `Set.notMember` deps) $ registers reg+    clear' d (Just b)  = fromMaybe (pure mempty) (fmap (clearBranch d) (branchOf b >>= (`chooseClear` b) . branchTag))+    {-# INLINE clear' #-}++    chooseClear ListT = Just . clearList+    chooseClear MapT = Just . clearMap+    chooseClear RegT = const Nothing++    clearBranch d clearWhich = do+      presence <- clearWhich deps+      modify (\d' -> addChild key d' d)+      pure presence+    {-# INLINE clearBranch #-}++stepNext :: Document Tag -> Cursor -> Cursor+stepNext d c@(Cursor (viewl -> Seq.EmptyL) (next -> getNextKey)) =+  let nextKey = getNextKey d+      newCur = Cursor mempty nextKey+  in case (nextKey /= Key Tail, Set.null (getPresence nextKey d)) of+    (True, True) -> stepNext d newCur+    (True, False) -> newCur+    (False, _) -> c++stepNext d c@(Cursor (viewl -> (x :< xs)) _) = maybe c f (findChild x d)+  where f nd = setFinalKey (finalKey $ stepNext nd (setPath xs c)) c+stepNext _ c = c++addChild :: Key Tag -> Document Tag -> Document Tag -> Document Tag+addChild _ _ d@(LeafDocument _) = d+addChild key child (BranchDocument d) = BranchDocument d { children = M.insert key child (children d)}++clearMap, clearList :: Document Tag -> Set Id -> State (Document Tag) (Set Id)+clearMap child deps = put child *> clearMap' mempty+  where+    clearMap' acc = do+      ms <- allKeys <$> get+      case Set.toList (ms Set.\\ acc) of+        [] -> pure mempty+        (k: _) -> do+          p1 <- clearElem deps (unTag k)+          p2 <- clearMap' (Set.insert k acc)+          pure (p1 `mappend` p2)+    allKeys (BranchDocument (Branch {branchTag = MapT, ..})) = keysSet children+    allKeys _ = mempty++clearList child deps = put child *> clearList' (Key Head)+  where+    clearList' (Key Tail) = pure mempty+    clearList' hasMore = do+      nextt <- next hasMore <$> get+      p1 <- clearElem deps hasMore+      p2 <- clearList' nextt+      pure (p1 `mappend` p2)++addId :: Mutation -> Key Tag -> Id -> Document Tag -> Document Tag+addId DeleteMutation _ _ d = d+addId _ t i (BranchDocument b) = BranchDocument b+  { presence = M.alter (maybe (Just $ Set.singleton i) (Just . Set.insert i)) (unTag t) $ presence b }+addId _ _ _ d = d++applyOp :: Operation -> Document Tag -> Document Tag+applyOp o@Operation{..} d = case viewl (path opCur) of+  EmptyL -> case opMutation of+    AssignMutation val -> case val of+      EmptyObject -> assignBranch MapT d+      EmptyArray -> assignBranch ListT d+      other -> assignLeaf other d+      where+        assignBranch tag = execState $ do+          let key@(Key k) = finalKey opCur+              tagged = tagWith tag k+          void $ clearElem opDeps key+          modify $ addId opMutation tagged opId+          child <- childGet tagged <$> get+          modify (addChild tagged child)+        assignLeaf other = execState $ do+          let tagged = tagWith RegT (basicKey $ finalKey opCur)+          void $ clear opDeps tagged+          modify $ addId opMutation tagged opId+          child <- childGet tagged <$> get+          case child of+            LeafDocument (RegDocument vals) -> do+              modify (addChild tagged $ LeafDocument $ RegDocument (M.insert opId other vals))++            branchChild -> modify (addChild tagged branchChild)++    InsertMutation val -> insert' nextKey+      where+        key = finalKey opCur+        nextKey = next key d+        insertNext =+          let newDoc = applyOp o+                { opCur = setPath mempty . setFinalKey (Key $ I opId) $ opCur+                , opMutation = AssignMutation val+                } d+          in case newDoc of+               BranchDocument b@Branch{branchTag = ListT} -> BranchDocument $ b+                 { keyOrder = M.insert (I opId) (basicKey nextKey) . M.insert (basicKey key) (I opId) $ keyOrder b}+               nd -> nd++        insert' k@(Key (I kid))+          | kid < opId = applyOp (o { opCur = setPath mempty . setFinalKey k $ opCur}) d+        insert' _ = insertNext++    DeleteMutation -> execState (clearElem opDeps (finalKey opCur)) d++  (x :< xs) ->+    let c = childGet x d+        child = applyOp (o {opCur = setPath xs opCur}) c+        newDoc = addId opMutation x opId d+    in addChild x child newDoc
+ src/Data/Crjdt/Eval.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Crjdt.Eval+  ( Eval(..)+  , EvalError(..)+  , addReceivedOps+  , run+  , evalEval+  , execEval+  , addVariable+  , execute+  , eval+  ) where++import Data.Void+import Data.Sequence (ViewL(..), viewl)+import qualified Data.Sequence as Seq+import Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Set as Set+import Data.Foldable (traverse_)++import Control.Exception (Exception)+import Control.Monad.Fix+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Free (iterM)++import Data.Crjdt.Types+import Data.Crjdt.Context+import Data.Crjdt.Internal.Core++data EvalError+  = GetOnHead+  | UndefinedVariable Var+  deriving (Show, Eq)++instance Exception EvalError++newtype Eval a = Eval+  { runEval :: ExceptT EvalError (State Context) a+  } deriving+  ( Functor+  , Applicative+  , Monad+  , MonadFix+  , MonadError EvalError+  , MonadState Context+  )++type Result = Cursor++initial :: ReplicaId -> Context+initial rid = Context+  { document = BranchDocument (Branch mempty mempty mempty MapT)+  , replicaGlobal = 0+  , variables = mempty+  , replicaId = rid+  , queue = mempty+  , history = mempty+  , received = mempty+  }++type Ctx m = (MonadError EvalError m, MonadState Context m)++run :: ReplicaId -> Eval a -> (Either EvalError a, Context)+run rid = (`runState` (initial rid)) . runExceptT . runEval++evalEval :: ReplicaId -> Expr -> Either EvalError Cursor+evalEval rid = (`evalState` (initial rid)) . runExceptT . runEval . eval++execEval :: ReplicaId -> Eval a -> Context+execEval rid = (`execState` (initial rid)) . runExceptT . runEval++valuesOf :: Ctx m => Expr -> m [Val]+valuesOf e = partsOf e RegT $ \case+  (LeafDocument l) -> M.elems (registers l)+  _ -> mempty++keysOf :: Ctx m => Expr -> m (Set.Set (Key Void))+keysOf e = partsOf e MapT $ \case+  (BranchDocument (Branch{branchTag = MapT,..})) -> M.keysSet $ M.filter (not . Set.null) presence+  _ -> mempty++partsOf :: (Ctx m, Monoid a) => Expr -> Tag -> (Document Tag -> a) -> m a+partsOf e tag f = eval e >>= \c -> partsOf' c f . document <$> get+  where+    partsOf' :: Monoid m => Cursor -> (Document Tag -> m) -> Document Tag -> m+    partsOf' Cursor{..} getParts d = fromMaybe mempty $ case viewl path of+      EmptyL -> getParts <$> findChild (tagWith tag $ basicKey finalKey) d+      (x :< xs) -> partsOf' (Cursor xs finalKey) getParts <$> findChild x d++addVariable :: Ctx m => Var -> Cursor -> m ()+addVariable v cur = modify $ \c -> c { variables = M.insert v cur (variables c)}+{-# INLINE addVariable #-}++addReceivedOps :: MonadState Context m => Seq.Seq Operation -> m ()+addReceivedOps ops = modify (\ctx -> ctx {received = ops `mappend` (received ctx)})++applyRemote :: Ctx m => m ()+applyRemote = get >>= \c ->+  let alreadyProcessed op cc = opId op `Set.member` history cc+      satisfiesDeps op cc = opDeps op `Set.isSubsetOf` history cc+      applyRemote' op = do+        cc <- get+        when (not (alreadyProcessed op cc) && satisfiesDeps op cc) $ put cc+          { replicaGlobal = replicaGlobal cc `max` (sequenceNumber . opId $ op)+          , document = applyOp op (document cc)+          , history = Set.insert (opId op) (history cc)+          }+  in traverse_ applyRemote' (received c)+{-# INLINE applyRemote #-}++applyLocal :: Ctx m => Mutation -> Cursor -> m ()+applyLocal mut cur = modify $ \c ->+  let op = Operation+        { opId = mkId (replicaGlobal c + 1) (replicaId c)+        , opDeps = history c+        , opCur = cur+        , opMutation = mut+        }+  in c { document = applyOp op (document c)+       , replicaGlobal = replicaGlobal c + 1+       , history = Set.insert (opId op) (history c)+       , queue = queue c Seq.|> op+       }+{-# INLINE applyLocal #-}++eval :: Ctx m => Expr -> m Result+eval Doc = pure $ Cursor Seq.empty $ unTag docKey+eval (GetKey expr k) = do+  cursor <- eval expr+  case finalKey cursor of+    (Key Head) -> throwError GetOnHead+    _ -> pure (appendWith MapT k cursor)+eval (Var var) = get >>= maybe (throwError (UndefinedVariable var)) pure . lookupCtx var+eval (Iter expr) = appendWith ListT (Key Head) <$> eval expr+eval (Next expr) = get >>= \(document -> d) -> stepNext d <$> eval expr++execCmd :: Ctx m => Cmd (m a) -> m a+execCmd (Let x expr c) = (eval expr >>= \cur -> addVariable (Variable x) cur *> pure (Var $ Variable x)) >>= c+execCmd (Assign expr v c) = (eval expr >>= applyLocal (AssignMutation v)) >> c+execCmd (InsertAfter expr v c) = (eval expr >>= applyLocal (InsertMutation v)) >> c+execCmd (Delete expr c) = (eval expr >>= applyLocal DeleteMutation) >> c+execCmd (Yield c) = applyRemote >> c+execCmd (Values expr c) = valuesOf expr >>= c+execCmd (Keys expr c) = keysOf expr >>= c++execute :: Ctx m => Command a -> m a+execute = iterM execCmd . runCommand
+ src/Data/Crjdt/Internal.hs view
@@ -0,0 +1,5 @@+module Data.Crjdt.Internal+  ( module Core+  ) where++import Data.Crjdt.Internal.Core as Core
+ src/Data/Crjdt/Internal/Core.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Crjdt.Internal.Core where++import Data.Text+import Data.Void+import Data.Set (Set)+import Control.Monad.Free+import Control.Applicative+import Data.String++import Data.Crjdt.Types++data Val+  = Number Int+  | StringLit Text+  | BoolLit Bool+  | Null+  | EmptyObject+  | EmptyArray+  deriving (Show, Eq)++instance IsString Val where+  fromString = StringLit . pack++data Cmd a+  = Let !Text !Expr (Expr -> a)+  | Assign !Expr !Val a+  | InsertAfter !Expr !Val a+  | Delete !Expr a+  | Values !Expr ([Val] -> a)+  | Keys !Expr (Set (Key Void) -> a)+  | Yield a+  deriving Functor++newtype Command a = Command { runCommand :: Free Cmd a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadFree Cmd+    )++data Expr+  = Doc+  | Var !Var+  | Iter !Expr+  | Next !Expr+  | GetKey !Expr !(Key Void)+  deriving (Show, Eq)++instance IsString Expr where+  fromString = Var . fromString
+ src/Data/Crjdt/Types.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.Crjdt.Types where++import Data.String+import Data.Text+import Data.Void++newtype Var = Variable { getName :: Text } deriving (Show, Eq, Ord)++instance IsString Var where+  fromString = Variable . fromString++data TaggedKey tag = TK+  { tag :: !tag+  , getKey :: !BasicKey+  } deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Show tag => Show (TaggedKey tag) where+  show (TK t k) = show (t, k)++-- TODO: rethink about this type+data Key tag where+  Key :: BasicKey -> Key Void+  TaggedKey :: TaggedKey tag -> Key tag++data BasicKey+  = DocKey+  | Head+  | Tail+  | I Id+  | Str Text+  deriving (Show, Eq, Ord)++instance (Ord tag, Eq tag) => Ord (Key tag) where+  (Key k) `compare` (Key k1) = k `compare` k1+  (TaggedKey k) `compare` (TaggedKey k1) = k `compare` k1++instance IsString (Key Void) where+  fromString = Key . Str . fromString++instance Show tag => Show (Key tag) where+  show (Key t) = show t+  show (TaggedKey taggedKey) = show taggedKey++instance Eq tag => Eq (Key tag) where+  (Key t) == (Key t1) = t == t1+  (TaggedKey t) == (TaggedKey t1) = t == t1+  (Key _) == (TaggedKey _) = False+  (TaggedKey _) == (Key _) = False++type ReplicaId = Integer+type GlobalReplicaCounter = Integer++newtype Id = Id { getId :: (GlobalReplicaCounter, ReplicaId) } deriving (Eq, Ord)++instance Show Id where+  show = show . getId++sequenceNumber = fst . getId+replicaNumber = snd . getId++mkId sn rid = Id (sn, rid)++tagWith :: tag -> BasicKey -> Key tag+tagWith t = TaggedKey . TK t++getTag :: Key tag -> tag+getTag (TaggedKey (TK t _)) = t++basicKey :: Key tag -> BasicKey+basicKey (Key k) = k+basicKey (TaggedKey (TK _ k)) = k++unTag :: Key tag -> Key Void+unTag (Key k) = Key k+unTag (TaggedKey (TK _ k)) = Key k++reTag :: a -> Key Void -> Key a+reTag given (Key k) = tagWith given k+reTag given (TaggedKey (TK _ k)) = tagWith given k
+ test/Data/CrjdtSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.CrjdtSpec where++import Test.Hspec+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Data.Map as M hiding (empty)+import Data.Either (isRight)+import Data.Maybe+import Data.Bifunctor+import Data.Foldable+import Data.Functor+import Control.Applicative (liftA2)+import Control.Monad++import Data.Crjdt+import Data.Crjdt.Internal++eitherToMaybe :: Either x a -> Maybe a+eitherToMaybe (Right a) = Just a+eitherToMaybe _ = Nothing++-- allProps :: IO ()+-- allProps = traverse_ check [property_let, property_var]++twenty = Range.linear 0 20++keyGen :: Monad m => Gen m BasicKey+keyGen = Gen.choice $ (pure <$> [Head, Tail, DocKey]) +++  [ I . Id <$> (liftA2 (fmap (bimap toInteger toInteger) . (,)) naturals naturals)+  , Str <$> Gen.text twenty Gen.hexit+  ]++naturals :: Monad m => Gen m Int+naturals = Gen.int (Range.linear 0 1000)++exprGen :: Gen IO Expr+exprGen = Gen.recursive Gen.choice terminal nonterminal+  where+    terminal = [pure doc]+    letVar = Gen.text twenty Gen.hexit >>= \t -> Let t <$> exprGen+    nonterminal =+      [ iter <$> exprGen+      , next <$> exprGen+      , key <$> (Key <$> keyGen) <*> exprGen+      ]++property_let :: Property+property_let = property $ do+  expr <- forAll exprGen+  name <- Variable <$> (forAll $ Gen.text twenty Gen.hexit)+  let (result, state) = run 1 $ execute $ bind (getName name) expr+  when (isRight result) $ do+    let Just cursor = M.lookup name $ variables $ state+        Right expectedCursor = evalEval 1 expr+    cursor === expectedCursor++property_var :: Property+property_var = property $ do+  expr <- forAll exprGen+  x <- Variable <$> (forAll $ Gen.text twenty Gen.hexit)+  let (result, c) = run 1 $ execute (bind (getName x) expr) *> eval (Var x)+      v = M.lookup x (variables c)+  v === eitherToMaybe result++property_get :: Property+property_get = property $ do+  expr <- forAll exprGen+  k <- forAll keyGen+  let cursor = evalEval 1 (GetKey expr $ Key k)+  when (k /= Head && isRight cursor) $ fmap finalKey cursor === Right (Key k)++checkH :: Property -> IO ()+checkH = void . check++spec :: Spec+spec = describe "Crjdt Specs" $+  describe "Expr evaluation" $ do+    it "DOC" $ evalEval 1 Doc `shouldBe` Right (Cursor mempty (Key DocKey))+    it "LET" $ checkH property_let+    it "VAR" $ checkH property_var+    it "GET" $ checkH property_get
+ test/Data/FigureSpec.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.FigureSpec where++import Test.Hspec++import Data.Map as Map hiding (insert, keys)+import Data.Set as Set+import Control.Monad.State++import Data.Crjdt as C+import Data.Crjdt.Internal++spec :: Spec+spec = describe "Figures from CRJDT paper" $ do+  let putRemote ops = modify (\ctx -> ctx { received = ops `mappend` (received ctx)})++  it "Figure 1" $ do+    let+      initial = execute (key "key" doc =: "A")+      r1 = initial+      r2 = initial+      r1next = r1 *> execute (key "key" doc =: "C")+      r2next = r2 *> execute (key "key" doc =: "D")++      (fr, firstState) = run 1 r1next+      (sr, secondState) = run 2 r2next++      r1yield = r1next *> putRemote (queue secondState) *> execute yield+      r2yield = r2next *> putRemote (queue firstState) *> execute yield++      (rr, r1Result) = run 1 r1yield+      (r2r, r2Result) = run 2 r2yield++    _ <- traverse (\x -> x `shouldBe` Right ()) [fr, sr, rr, r2r]++    document firstState `shouldSatisfy` (/= (document secondState))+    document r1Result `shouldBe` document r2Result+    history r1Result `shouldBe` history r2Result++    let+      p = Set.fromList [mkId 1 1, mkId 1 2, mkId 2 1, mkId 2 2]+      docPresence = Map.fromList [(Key DocKey, p)]+      keyPresence = Map.fromList [("key", p)]+      leaf = RegDocument $ Map.fromList $ [(mkId 2 1, "C"),(mkId 2 2, "D")]++      innerMap = Branch+        { children = Map.fromList [(tagWith RegT (Str "key"), LeafDocument leaf)]+        , presence = keyPresence+        , keyOrder = mempty+        , branchTag = MapT+        }++      parent = Branch+        { children = Map.fromList [(tagWith MapT DocKey, BranchDocument innerMap)]+        , presence = docPresence+        , keyOrder = mempty+        , branchTag = MapT+        }++      d = BranchDocument parent++    document r1Result `shouldBe` d++  it "Figure 2" $ do+    let r1 = do+          var <- bind "var" (key "colors" doc)+          key "blue" var =: "#0000ff"++        (_, r1result) = run 1 $ execute r1++        r1next = do+          r1+          key "red" "var" =: "#ff0000"++        r2next = putRemote (queue r1result) *> execute yield *> execute (do+            key "colors" doc =: emptyMap+            key "green" (key "colors" doc) =: "#00ff00”"+          )++        (r1r, r1State) = run 1 $ execute (r1next *> keys (key "colors" doc))+        (r2r, r2State) = run 2 (r2next *> execute (keys (key "colors" doc)))++        r1Final = execute r1next *> putRemote (queue r2State) *> execute (yield *> keys (key "colors" doc))+        r2Final = r2next *> putRemote (queue r1State) *> execute (yield *> keys (key "colors" doc))++        (Right keys1, finalResult1) = run 1 r1Final+        (Right keys2, finalResult2) = run 2 r2Final++    keys1 `shouldBe` keys2+    keys1 `shouldBe` Set.fromList ["red", "green"]++    document finalResult1 `shouldBe` document finalResult2+    history finalResult1 `shouldBe` history finalResult2++  it "Figure 3" $ do+    let cmd1 = do+          key "grocery" doc =: emptyList+          C.insert "eggs" (iter $ key "grocery" doc)+          eggs <- bind "eggs" (next (iter (key "grocery" doc)))+          C.insert "ham" eggs++    let cmd2 = do+          key "grocery" doc =: emptyMap+          C.insert "milk" (iter (key "grocery" doc))+          milk <- bind "milk" (next (iter (key "grocery" doc)))+          C.insert "flour" milk+    let (Right (), r1State) = run 1 $ execute cmd1+        (Right (), r2State) = run 2 $ execute cmd2++    let getValues = do+          eggs <- values "eggs"+          milk <- values (next $ "eggs")+          ham <- values (next $ next $ "eggs")+          flour <- values (next $ next $ next $ "eggs")+          pure (eggs ++ milk ++ ham ++ flour)++    let (Right xs, r1Final) = run 1 (execute cmd1 *> putRemote (queue r2State) *> execute (yield *> getValues))+        (Right (), r2Final) = run 2 (execute cmd2 *> putRemote (queue r1State) *> execute yield)+++    xs `shouldBe` ["eggs", "milk", "ham", "flour"]++    document r1Final  `shouldBe` document r2Final+    -- grocery `shouldBe` expectedGrocery++  describe "Empty updates" $ do+    let test what = do+          let cmd = key "g" doc =: what+              cmd1 = cmd+              (Right (), r) = run 1 $ execute cmd+              (Right (), r1) = run 2 $ execute cmd1++          let (Right (), x1) = run 1 (execute cmd *> putRemote (queue r1) *> execute yield)+              (Right (), x2) = run 2 (execute cmd1 *> putRemote (queue r) *> execute yield)++          document x1 `shouldBe` document x2++    it "Empty object update" $ test emptyMap+    it "Empty list update" $ test emptyList++  it "Figure 4" $ do+    let cmd = do+          todo <- "todo" -< iter (key "todo" doc)+          C.insert emptyMap "todo"+          key "title" (next $ "todo") =: "buy milk"+          key "done" (next $ "todo") =: "false"++        (Right (), cmdResult) = run 1 $ execute cmd+        r1next = cmd *> C.delete (next $ "todo")+        r2 = key "done" (next $ iter $ key "todo" doc) =: "true"+        r2next = putRemote (queue cmdResult) *> execute yield *> execute r2+        (Right (), r1St) = run 1 $ execute r1next+        (Right (), r2St) = run 2 $ r2next++        (Right keys1, r1Final) = run 1 (execute r1next *> putRemote (queue r2St) *> execute (yield *> keys (next $ iter $ key "todo" doc)))+        (Right keys2, r2Final) = run 2 (r2next *> putRemote (queue r1St) *> execute (yield *> keys (next $ iter $ key "todo" doc)))++    keys1 `shouldBe` keys2+    keys1 `shouldBe` Set.fromList ["done"]+    document r1Final `shouldBe` document r2Final++  it "Figure 6" $ do+    let cmd = do+          doc =: emptyMap+          list <- bind "list" $ doc .> key "shopping" .> iter+          C.insert "eggs" list+          eggs <- bind "eggs" (next list)+          C.insert "milk" eggs+          C.insert "cheese" list++        (Right xs, _) = run 1 $ execute $ cmd *> do+          eggs <- values "eggs"+          milk <- values ("eggs" .> next)+          cheese <- values ("eggs" .> next .> next)+          pure (eggs ++ milk ++ cheese)++    xs `shouldBe` ["eggs", "milk", "cheese"]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}