cfa7253 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

cfa7253AgentM8 years ago

src/lib/ProjectM36/Atom.hs+1−1

compare with master

unifiedsplit

@@ -3,7 +3,7 @@ import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.DataTypes.Interval

5import qualified Data.Text as T

6−import Data.Monoid

6+--import Data.Monoid

8relationForAtom :: Atom -> Either RelationalError Relation

9relationForAtom (RelationAtom rel) = Right rel

src/lib/ProjectM36/Base.hs+11−4

@@ -24,6 +24,7 @@ import Data.Time.Calendar (Day,toGregorian,fromGregorian)

24import Data.Hashable.Time ()

25import Data.Typeable

26import Data.ByteString (ByteString)

27+import qualified Data.List.NonEmpty as NE

27type StringType = Text

28type StringType = Text

29-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

30-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

@@ -262,7 +263,7 @@ data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructo

262 deriving (Show, Generic, Binary, Eq, NFData)

263 deriving (Show, Generic, Binary, Eq, NFData)

263

264

264type InclusionDependencies = M.Map IncDepName InclusionDependency

265type InclusionDependencies = M.Map IncDepName InclusionDependency

265−type RelationVariables = M.Map RelVarName Relation

266+type RelationVariables = M.Map RelVarName RelationVariable --change to RelationalExprBase TransactionId

266

267

267type SchemaName = StringType

268type SchemaName = StringType

268

269

@@ -374,13 +375,19 @@ type TransactionHeads = M.Map HeadName Transaction

374data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

375data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

375

376

376-- | Every transaction has context-specific information attached to it.

377-- | Every transaction has context-specific information attached to it.

377−-- The `TransactionDiff`s represent child/edge relationships to subsequent transactions (branches or continuations of the same branch).

378+-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

379+data TransactionInfo = TransactionInfo {

380+ parents :: TransactionDiffs,

381+ stamp :: UTCTime

382+ } deriving (Show, Generic)

383+{-

378data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children

384data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children

379 MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children

385 MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children

380− deriving(Show, Generic)

386+ deriving (Show, Generic)

387+-}

381

388

382-- | Each child transaction must have a corresponding difference expression.

389-- | Each child transaction must have a corresponding difference expression.

383−type TransactionDiffs = [(TransactionId, TransactionDiffExpr)]

390+type TransactionDiffs = NE.NonEmpty (TransactionId, TransactionDiffExpr)

384

391

385instance Binary TransactionInfo

392instance Binary TransactionInfo

386

393

src/lib/ProjectM36/Client.hs+16−15

@@ -46,7 +46,8 @@ module ProjectM36.Client

46 PersistenceStrategy(..),

47 RelationalExpr,

48 RelationalExprBase(..),

49− DatabaseContextExpr(..),

49+ DatabaseContextExprBase(..),

50+ DatabaseContextExpr,

50 DatabaseContextIOExpr(..),

51 DatabaseContextIOExpr(..),

51 Attribute(..),

52 Attribute(..),

52 MergeStrategy(..),

53 MergeStrategy(..),

@@ -152,7 +153,6 @@ import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match

152import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

153import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

153import Control.Concurrent.MVar

154import Control.Concurrent.MVar

154import qualified Data.Map as M

155import qualified Data.Map as M

155−import Control.Distributed.Process.Serializable (Serializable)

156#if MIN_VERSION_stm_containers(1,0,0)

157import qualified StmContainers.Map as StmMap

158import qualified StmContainers.Set as StmSet

@@ -163,12 +163,13 @@ import qualified STMContainers.Set as StmSet

163import qualified ProjectM36.Session as Sess

164import ProjectM36.Session

165import ProjectM36.Sessions

166−import "list-t" ListT

166+--import "list-t" ListT

167import Data.Binary (Binary)

168import GHC.Generics (Generic)

169import Control.DeepSeq (force)

170import System.IO

171import Data.Time.Clock

172+import Data.Typeable

172

173

173type Hostname = String

174type Hostname = String

174

175

@@ -311,9 +312,9 @@ connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

311--create a new in-memory database/transaction graph

312--create a new in-memory database/transaction graph

312connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

313connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

313 freshId <- nextRandom

314 freshId <- nextRandom

314− stamp <- getCurrentTime

315+ tstamp <- getCurrentTime

315 let bootstrapContext = basicDatabaseContext

316 let bootstrapContext = basicDatabaseContext

316− freshGraph = bootstrapTransactionGraph stamp freshId bootstrapContext

317+ freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapContext

317 case strat of

318 case strat of

318 --create date examples graph for now- probably should be empty context in the future

319 --create date examples graph for now- probably should be empty context in the future

319 NoPersistence -> do

320 NoPersistence -> do

@@ -409,7 +410,7 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do

409 case transactionForId commitId graph of

410 case transactionForId commitId graph of

410 Left err -> pure (Left err)

411 Left err -> pure (Left err)

411 Right transaction -> do

412 Right transaction -> do

412− let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False

413+ let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) NoOperation

413 keyDuplication <- StmMap.lookup newSessionId sessions

414 keyDuplication <- StmMap.lookup newSessionId sessions

414 case keyDuplication of

415 case keyDuplication of

415 Just _ -> pure $ Left (SessionIdInUseError newSessionId)

416 Just _ -> pure $ Left (SessionIdInUseError newSessionId)

@@ -494,7 +495,7 @@ safeLogin login procId = do

494 Left (_ :: ServerError) -> pure False

495 Left (_ :: ServerError) -> pure False

495 Right val -> pure val

496 Right val -> pure val

496

497

497−remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b

498+remoteCall :: (Binary a, Binary b, Typeable a, Typeable b) => Connection -> a -> IO b

498remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"

499remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"

499remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

500remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

500 ret <- safeCall serverProcessId arg

501 ret <- safeCall serverProcessId arg

@@ -601,7 +602,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

601 (Left err,_) -> pure (Left err)

602 (Left err,_) -> pure (Left err)

602 (Right (), (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do

603 (Right (), (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do

603 (Right (), (!context',_,True)) -> do

604 (Right (), (!context',_,True)) -> do

604− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True

605+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

605 newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

606 newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

606 newSchemas = Schemas context' newSubschemas

607 newSchemas = Schemas context' newSubschemas

607 newSession = Session newDiscon (Sess.schemaName session)

608 newSession = Session newDiscon (Sess.schemaName session)

@@ -616,7 +617,7 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

616 id1 <- nextRandom

617 id1 <- nextRandom

617 id2 <- nextRandom

618 id2 <- nextRandom

618 id3 <- nextRandom

619 id3 <- nextRandom

619− stamp <- getCurrentTime

620+ tstamp <- getCurrentTime

620 commitLock_ sessionId conf $ \graph -> do

621 commitLock_ sessionId conf $ \graph -> do

621 eSession <- sessionForSessionId sessionId sessions

622 eSession <- sessionForSessionId sessionId sessions

622 case eSession of

623 case eSession of

@@ -627,10 +628,10 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

627 Just headTrans -> do

628 Just headTrans -> do

628 --attempt fast-forward commit, if possible

629 --attempt fast-forward commit, if possible

629 let graphInfo = if Sess.parentId session == transactionId headTrans then do

630 let graphInfo = if Sess.parentId session == transactionId headTrans then do

630− ret <- Graph.evalGraphOp stamp id1 (Sess.disconnectedTransaction session) graph Commit

631+ ret <- Graph.evalGraphOp tstamp id1 (Sess.disconnectedTransaction session) graph Commit

631 pure (ret, [id1])

632 pure (ret, [id1])

632 else do

633 else do

633− ret <- Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph

634+ ret <- Graph.autoMergeToHead tstamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph

634 pure (ret, [id1,id2,id3])

635 pure (ret, [id1,id2,id3])

635 case graphInfo of

636 case graphInfo of

636 Left err -> pure (Left err)

637 Left err -> pure (Left err)

@@ -652,7 +653,7 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEith

652 case res of

653 case res of

653 Left err -> pure (Left err)

654 Left err -> pure (Left err)

654 Right context' -> do

655 Right context' -> do

655− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True

656+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

656 newSchemas = Schemas context' (Sess.subschemas session)

657 newSchemas = Schemas context' (Sess.subschemas session)

657 newSession = Session newDiscon (Sess.schemaName session)

658 newSession = Session newDiscon (Sess.schemaName session)

658 atomically $ StmMap.insert newSession sessionId sessions

659 atomically $ StmMap.insert newSession sessionId sessions

@@ -694,14 +695,14 @@ executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (E

694executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

695executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

695 let sessions = ipSessions conf

696 let sessions = ipSessions conf

696 freshId <- nextRandom

697 freshId <- nextRandom

697− stamp <- getCurrentTime

698+ tstamp <- getCurrentTime

698 commitLock_ sessionId conf $ \updatedGraph -> do

699 commitLock_ sessionId conf $ \updatedGraph -> do

699 eSession <- sessionForSessionId sessionId sessions

700 eSession <- sessionForSessionId sessionId sessions

700 case eSession of

701 case eSession of

701 Left err -> pure (Left err)

702 Left err -> pure (Left err)

702 Right session -> do

703 Right session -> do

703 let discon = Sess.disconnectedTransaction session

704 let discon = Sess.disconnectedTransaction session

704− case evalGraphOp stamp freshId discon updatedGraph graphExpr of

705+ case evalGraphOp tstamp freshId discon updatedGraph graphExpr of

705 Left err -> pure (Left err)

706 Left err -> pure (Left err)

706 Right (discon', graph') -> do

707 Right (discon', graph') -> do

707 --if freshId appears in the graph, then we need to pass it on

708 --if freshId appears in the graph, then we need to pass it on

@@ -807,7 +808,7 @@ executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $

807 --hm- maybe we should start using lenses

808 --hm- maybe we should start using lenses

808 let discon = Sess.disconnectedTransaction session

809 let discon = Sess.disconnectedTransaction session

809 newSchemas = Schemas newContext newSubschemas

810 newSchemas = Schemas newContext newSubschemas

810− newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas True) (Sess.schemaName session)

811+ newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas NoOperation) (Sess.schemaName session)

811 StmMap.insert newSession sessionId sessions

812 StmMap.insert newSession sessionId sessions

812 pure (Right ())

813 pure (Right ())

813executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

814executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

src/lib/ProjectM36/Client/Simple.hs+2−1

@@ -25,7 +25,8 @@ module ProjectM36.Client.Simple (

25 C.PersistenceStrategy(..),

26 C.NotificationCallback,

27 C.emptyNotificationCallback,

28− C.DatabaseContextExpr(..),

28+ C.DatabaseContextExprBase(..),

29+ C.DatabaseContextExpr,

29 C.RelationalExprBase(..)

30 C.RelationalExprBase(..)

30 ) where

31 ) where

src/lib/ProjectM36/DataFrame.hs+1−1

@@ -18,7 +18,7 @@ import Data.Maybe

18import qualified Data.Text as T

19import Data.Binary

20import Control.Arrow

21−import Data.Monoid

21+--import Data.Monoid

23data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

24data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

src/lib/ProjectM36/IsomorphicSchema.hs+1−1

@@ -14,7 +14,7 @@ import Data.Binary

14import qualified Data.Map as M

15import qualified Data.Set as S

16import qualified Data.List as L

17−import Data.Monoid

17+--import Data.Monoid

18-- isomorphic schemas offer bi-directional functors between two schemas

20--TODO: note that renaming a relvar should alter any stored isomorphisms as well

src/lib/ProjectM36/Key.hs+1−1

@@ -2,7 +2,7 @@ module ProjectM36.Key where

2import ProjectM36.Base

3import ProjectM36.Relation

4import qualified Data.Set as S

5−import Data.Monoid

5+--import Data.Monoid

7{-

8keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth

src/lib/ProjectM36/Relation/Show/HTML.hs+1−1

@@ -8,7 +8,7 @@ import qualified Data.List as L

8import Data.Text (Text, pack)

9import qualified Data.Text as T

10import qualified Data.Text.IO as TIO

11−import Data.Monoid

11+--import Data.Monoid

12import qualified Data.Vector as V

14attributesAsHTML :: Attributes -> Text

src/lib/ProjectM36/Relation/Show/Term.hs+1−1

@@ -9,7 +9,7 @@ import ProjectM36.Attribute hiding (null)

9import qualified Data.List as L

10import qualified Data.Text as T

11import Control.Arrow hiding (left)

12−import Data.Monoid

12+--import Data.Monoid

13import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal

15boxV :: StringType

src/lib/ProjectM36/Server/EntryPoints.hs+3−3

@@ -3,17 +3,17 @@ import ProjectM36.Base hiding (inclusionDependencies)

3import ProjectM36.IsomorphicSchema

4import ProjectM36.Client as C

5import ProjectM36.Error

6−import ProjectM36.DataFrame

7import Control.Distributed.Process (Process, ProcessId)

6import Control.Distributed.Process (Process, ProcessId)

8import Control.Distributed.Process.ManagedProcess (ProcessReply)

7import Control.Distributed.Process.ManagedProcess (ProcessReply)

9import Control.Distributed.Process.ManagedProcess.Server (reply)

8import Control.Distributed.Process.ManagedProcess.Server (reply)

10import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))

9import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))

11−import Control.Distributed.Process.Serializable (Serializable)

12import Control.Monad.IO.Class (liftIO)

10import Control.Monad.IO.Class (liftIO)

13import Data.Map

11import Data.Map

14import Control.Concurrent (threadDelay)

12import Control.Concurrent (threadDelay)

13+import Data.Typeable

14+import Data.Binary

16−timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)

16+timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a)

17timeoutOrDie micros act =

18 if micros == 0 then

19 liftIO act >>= \x -> pure (Right x)

src/lib/ProjectM36/Server/ParseArgs.hs+1−1

@@ -3,7 +3,7 @@ import ProjectM36.Base

3import ProjectM36.Client

4import Options.Applicative

5import ProjectM36.Server.Config

6−import Data.Monoid

6+--import Data.Monoid

8parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig

9parseArgsWithDefaults defaults = ServerConfig <$>

src/lib/ProjectM36/Sessions.hs−1

@@ -8,7 +8,6 @@ import qualified StmContainers.Set as StmSet

8import qualified STMContainers.Map as StmMap

9import qualified STMContainers.Set as StmSet

10#endif

11−import "list-t" ListT

12import ProjectM36.Attribute

11import ProjectM36.Attribute

13import ProjectM36.Base

12import ProjectM36.Base

14import ProjectM36.Session

13import ProjectM36.Session

src/lib/ProjectM36/TransGraphPlanExpr.hsnew file+5

@@ -0,0 +1,5 @@

1+module ProjectM36.TransGraphPlanExpr where

2+import ProjectM36.Base

3+-- used to create an execution plan which can potentially read from the query cache

5+data TransGraphPlanExpr = ExecuteTransGraphRelationalExprPlan TransGraphRelationalExpr

src/lib/ProjectM36/Transaction.hs+17−23

@@ -3,31 +3,20 @@ import ProjectM36.Base

3import qualified Data.Set as S

4import qualified Data.UUID as U

5import Data.Time.Clock

6+import qualified Data.List.NonEmpty as NE

7+import ProjectM36.TransactionDiffs

7−transactionTimestamp :: Transaction -> UTCTime

8−transactionTimestamp (Transaction _ (TransactionInfo _ _ stamp) _) = stamp

9−transactionTimestamp (Transaction _ (MergeTransactionInfo _ _ _ stamp) _) = stamp

10−

11−transactionParentIds :: Transaction -> S.Set TransactionId

9+parentIds :: Transaction -> S.Set TransactionId

12−transactionParentIds (Transaction _ (TransactionInfo pId _ _) _) = S.singleton pId

10+parentIds (Transaction _ tinfo _) = S.fromList (NE.toList (NE.map fst (parents tinfo)))

13−transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _) = S.fromList [pId1, pId2]

14−

15−transactionChildIds :: Transaction -> S.Set TransactionId

16−transactionChildIds (Transaction _ (TransactionInfo _ children _) _) = S.fromList (map fst children)

17−transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children _) _) = S.fromList (map fst children)

18−

19−-- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.

20−transactionSetChildren :: Transaction -> TransactionDiffs -> Transaction

21−transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') diffs' = Transaction (transactionId t) (TransactionInfo pId diffs' stamp) schemas'

22−transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') diffs' = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 diffs' stamp) schemas'

24-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

12-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

25filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

13filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

26−filterTransactionInfoTransactions filterIds (TransactionInfo parentId diffs' stamp) = TransactionInfo (filterParent parentId filterIds) (filterDiffs filterIds diffs') stamp

14+filterTransactionInfoTransactions filterIds tinfo =

27−filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB diffs' stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (filterDiffs filterIds diffs') stamp

15+ TransactionInfo { parents = case

28−

16+ NE.filter (\diff -> S.member (fst diff) filterIds) (parents tinfo) of

29−filterDiffs :: S.Set TransactionId -> TransactionDiffs -> TransactionDiffs

17+ [] -> root

30−filterDiffs filterIds = filter (\(tid,_) -> S.member tid filterIds)

18+ xs -> NE.fromList xs,

19+ stamp = stamp tinfo }

32filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

21filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

33filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

22filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

@@ -49,5 +38,10 @@ subschemas :: Transaction -> Subschemas

49subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

38subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

51diffs :: Transaction -> TransactionDiffs

40diffs :: Transaction -> TransactionDiffs

52−diffs (Transaction _ (TransactionInfo _ diffs' _) _) = diffs'

41+diffs (Transaction _ info _) = parents info

53−diffs (Transaction _ (MergeTransactionInfo _ _ diffs' _) _) = diffs'

42+

43+fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

44+fresh freshId stamp' newSchemas = Transaction freshId (TransactionInfo root stamp') newSchemas

45+

46+timestamp :: Transaction -> UTCTime

47+timestamp (Transaction _ tinfo _) = stamp tinfo

src/lib/ProjectM36/TransactionDiffs.hs+7−2

@@ -1,5 +1,10 @@

1module ProjectM36.TransactionDiffs where

2import ProjectM36.Base

3+import Data.List.NonEmpty

4+import Data.UUID as U

6+root :: TransactionDiffs

7+root = single U.nil NoOperation

4−empty :: TransactionDiffs

9+single :: TransactionId -> TransactionDiffExpr -> TransactionDiffs

5−empty = []

10+single tid expr = (tid, expr) :| []

src/lib/ProjectM36/TransactionGraph.hs+80−73

@@ -16,13 +16,14 @@ import qualified ProjectM36.Attribute as A

16import qualified Data.UUID as U

17import qualified Data.Set as S

18import qualified Data.Map as M

19+import qualified Data.List.NonEmpty as NE

19import Control.Monad

20import Control.Monad

20import Data.Time.Clock

21import Data.Time.Clock

21import qualified Data.Text as T

22import qualified Data.Text as T

22import GHC.Generics

23import GHC.Generics

23import Data.Binary

24import Data.Binary

24import Data.Either (lefts, rights, isRight)

25import Data.Either (lefts, rights, isRight)

25−import Data.Monoid

26+--import Data.Monoid

26import Control.Arrow

27import Control.Arrow

27import Data.Maybe

28import Data.Maybe

@@ -63,11 +64,11 @@ data ROTransactionGraphOperator = ShowGraph

63 deriving Show

64 deriving Show

65bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph

66bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph

66−bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

67+bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

67 where

68 where

68 bootstrapHeads = M.singleton "master" freshTransaction

69 bootstrapHeads = M.singleton "master" freshTransaction

69 newSchemas = Schemas context M.empty

70 newSchemas = Schemas context M.empty

70− freshTransaction = Transaction freshId (TransactionInfo U.nil TD.empty stamp) newSchemas

71+ freshTransaction = fresh freshId stamp' newSchemas

71 bootstrapTransactions = S.singleton freshTransaction

72 bootstrapTransactions = S.singleton freshTransaction

73emptyTransactionGraph :: TransactionGraph

74emptyTransactionGraph :: TransactionGraph

@@ -108,57 +109,58 @@ transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either Relation

108transactionsForIds idSet graph =

109transactionsForIds idSet graph =

109 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

110 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

110

111

112+-- | A root transaction terminates a graph and has no parents.

111−isRootTransaction :: Transaction -> TransactionGraph -> Bool

113+isRootTransaction :: Transaction -> Bool

112−isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

114+isRootTransaction trans = diffs trans == TD.root

113−isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

114

115

115-- the first transaction has no parent - all other do have parents- merges have two parents

116-- the first transaction has no parent - all other do have parents- merges have two parents

116parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

117parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

117−parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph =

118+parentTransactions trans graph = transactionsForIds (parentIds trans) graph

118− S.singleton <$> transactionForId pId graph

119−

120−

121−parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

122−

123

119

124childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

120childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

125−childTransactions trans = transactionsForIds (transactionChildIds trans)

121+childTransactions trans graph = transactionsForIds childIds graph

122+ where

123+ childIds = S.map transactionId (S.filter filt (transactionsForGraph graph))

124+ filt trans' = S.member (transactionId trans) (parentIds trans')

126

125

127-- create a new commit and add it to the heads

126-- create a new commit and add it to the heads

128-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

127-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

129addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

128addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

130−addBranch stamp newId newBranchName branchPointId graph = do

129+addBranch stamp' newId newBranchName branchPointId graph = do

131 parentTrans <- transactionForId branchPointId graph

130 parentTrans <- transactionForId branchPointId graph

132− let newTrans = Transaction newId (TransactionInfo branchPointId TD.empty stamp) (schemas parentTrans)

131+ let newTrans = Transaction newId (TransactionInfo {

132+ parents = TD.single branchPointId NoOperation,

133+ stamp = stamp'}) (schemas parentTrans)

133− addTransactionToGraph newBranchName newTrans [(newId, NoOperation)] graph

134+ addTransactionToGraph newBranchName newTrans graph

134

135

135--adds a disconnected transaction to a transaction graph at some head

136--adds a disconnected transaction to a transaction graph at some head

136addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

137addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

137−addDisconnectedTransaction stamp newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId TD.empty stamp) schemas') [(newId, Discon.diffExpr discon)]

138+addDisconnectedTransaction stamp' newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans

139+ where

140+ newTrans = Transaction newId (TransactionInfo {

141+ parents = TD.single parentId (Discon.diffExpr discon),

142+ stamp = stamp'}) schemas'

138

143

139

144

140−addTransactionToGraph :: HeadName -> Transaction -> TransactionDiffs -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

145+addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

141−addTransactionToGraph headName newTrans transDiffs graph = do

146+addTransactionToGraph headName newTrans graph = do

142− let parentIds = transactionParentIds newTrans

147+ let parentIds' = parentIds newTrans

143− childIds = transactionChildIds newTrans

144 newId = transactionId newTrans

148 newId = transactionId newTrans

145 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)

149 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)

146− addChildTransaction trans = transactionSetChildren trans (transDiffs ++ diffs trans)

150+ childTs <- childTransactions newTrans graph

147 --validate that the parent transactions are in the graph

151 --validate that the parent transactions are in the graph

148− _ <- validateIds parentIds

152+ _ <- validateIds parentIds'

149− when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)

153+ when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId)

150 --if the headName already exists, ensure that it refers to a parent

154 --if the headName already exists, ensure that it refers to a parent

151 case transactionForHead headName graph of

155 case transactionForHead headName graph of

152 Nothing -> pure () -- any headName is OK

156 Nothing -> pure () -- any headName is OK

153− Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))

157+ Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))

154 --validate that the transaction has no children

158 --validate that the transaction has no children

155− unless (S.null childIds) (Left $ NewTransactionMayNotHaveChildrenError newId)

159+ unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)

156 --validate that the trasaction's id is unique

160 --validate that the trasaction's id is unique

157 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

161 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

158− --update the parent transactions to point to the new transaction

162+

159− parents <- mapM (`transactionForId` graph) (S.toList parentIds)

160− let updatedParents = S.map addChildTransaction (S.fromList parents)

161− updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))

163+ let updatedTransSet = S.insert newTrans (transactionsForGraph graph)

162 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

164 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

163 pure (newTrans, TransactionGraph updatedHeads updatedTransSet)

165 pure (newTrans, TransactionGraph updatedHeads updatedTransSet)

164

166

@@ -250,15 +252,15 @@ evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph

250

252

251-- create a new commit and add it to the heads

253-- create a new commit and add it to the heads

252-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

254-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

253−evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

255+evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

254 let newDiscon = Discon.freshTransaction newId schemas'

256 let newDiscon = Discon.freshTransaction newId schemas'

255− case addBranch stamp newId newBranchName parentId graph of

257+ case addBranch stamp' newId newBranchName parentId graph of

256 Left err -> Left err

258 Left err -> Left err

257 Right (_, newGraph) -> Right (newDiscon, newGraph)

259 Right (_, newGraph) -> Right (newDiscon, newGraph)

258

260

259-- add the disconnected transaction to the graph

261-- add the disconnected transaction to the graph

260-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

262-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

261−evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of

263+evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of

262 Left err -> Left err

264 Left err -> Left err

263 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

265 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

264 Nothing -> Left $ TransactionIsNotAHeadError parentId

266 Nothing -> Left $ TransactionIsNotAHeadError parentId

@@ -267,7 +269,7 @@ evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _

267 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

269 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

268 where

270 where

269 newDisconnectedTrans = Discon.freshTransaction newTransId schemas'

271 newDisconnectedTrans = Discon.freshTransaction newTransId schemas'

270− maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

272+ maybeUpdatedGraph = addDisconnectedTransaction stamp' newTransId headName discon graph

271

273

272-- refresh the disconnected transaction, return the same graph

274-- refresh the disconnected transaction, return the same graph

273evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of

275evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of

@@ -276,7 +278,7 @@ evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case tra

276 where

278 where

277 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

279 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

278

280

279−evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph

281+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph

280

282

281evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

283evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

282 Nothing -> Left (NoSuchHeadNameError branchName)

284 Nothing -> Left (NoSuchHeadNameError branchName)

@@ -298,7 +300,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

298 tupleGenerator transaction = case transactionParentsRelation transaction graph of

300 tupleGenerator transaction = case transactionParentsRelation transaction graph of

299 Left err -> Left err

301 Left err -> Left err

300 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

302 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

301− DateTimeAtom (transactionTimestamp transaction),

303+ DateTimeAtom (timestamp transaction),

302 RelationAtom parentTransRel,

304 RelationAtom parentTransRel,

303 BoolAtom $ parentId == transactionId transaction,

305 BoolAtom $ parentId == transactionId transaction,

304 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

306 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

@@ -306,7 +308,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

306

308

307transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation

309transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation

308transactionParentsRelation trans graph =

310transactionParentsRelation trans graph =

309− if isRootTransaction trans graph then

311+ if isRootTransaction trans then

310 mkRelation attrs emptyTupleSet

312 mkRelation attrs emptyTupleSet

311 else do

313 else do

312 parentTransSet <- parentTransactions trans graph

314 parentTransSet <- parentTransactions trans graph

@@ -326,15 +328,18 @@ evalROGraphOp discon graph ShowGraph = do

326

328

327-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

329-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

328createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

330createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

329−createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

331+createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

330 let selectedTrans = validateHeadName selectedBranch graph t2

332 let selectedTrans = validateHeadName selectedBranch graph t2

331− Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) TD.empty stamp) . schemas <$> selectedTrans

333+ Transaction newId (TransactionInfo {

334+ parents = NE.fromList [(transactionId trans1, undefined),

335+ (transactionId trans2, undefined)],

336+ stamp = stamp' }) . schemas <$> selectedTrans

332

337

333-- merge functions, relvars, individually

338-- merge functions, relvars, individually

334−createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

339+createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

335

340

336-- merge function, relvars, but, on error, just take the component from the preferred branch

341-- merge function, relvars, but, on error, just take the component from the preferred branch

337−createMergeTransaction stamp newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp newId strat graph t2

342+createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

338

343

339-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

344-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

340validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

345validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

@@ -355,7 +360,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

355 Right (TransactionGraph resultHeads traverseSet) -- add filter

360 Right (TransactionGraph resultHeads traverseSet) -- add filter

356 --catch root transaction to improve error?

361 --catch root transaction to improve error?

357 else do

362 else do

358− currentTransChildren <- S.fromList <$> mapM (`transactionForId` origGraph) (S.toList (transactionChildIds currentTrans))

363+ currentTransChildren <- childTransactions currentTrans origGraph

359 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren

364 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren

360 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)

365 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)

361 childSearches = map searchChild (S.toList searchChildren)

366 childSearches = map searchChild (S.toList searchChildren)

@@ -374,9 +379,8 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

374 else -- we found a path

379 else -- we found a path

375 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

380 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

376 where

381 where

377− oneParent (Transaction _ (TransactionInfo parentId _ _) _) = transactionForId parentId origGraph

382+ oneParent (Transaction _ tinfo _) = transactionForId (fst (NE.head (parents tinfo))) origGraph

378− oneParent (Transaction _ (MergeTransactionInfo parentId _ _ _) _) = transactionForId parentId origGraph

383+

379−

380-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.

384-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.

381pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

385pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

382pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

386pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

@@ -384,11 +388,11 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

384 if transactionId targetTransaction == transactionId currentTransaction then

388 if transactionId targetTransaction == transactionId currentTransaction then

385 Right accumTransSet

389 Right accumTransSet

386 else do

390 else do

387− currentTransChildren <- mapM (`transactionForId` graph) (S.toList (transactionChildIds currentTransaction))

391+ currentTransChildren <- childTransactions currentTransaction graph

388 if null currentTransChildren then

392 if null currentTransChildren then

389 Left (FailedToFindTransactionError targetId)

393 Left (FailedToFindTransactionError targetId)

390 else do

394 else do

391− let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren

395+ let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)

392 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)

396 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)

393 paths = rights searches

397 paths = rights searches

394 if not (null realErrors) then -- found some real errors

398 if not (null realErrors) then -- found some real errors

@@ -399,7 +403,7 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

399 Right (S.unions paths)

403 Right (S.unions paths)

400

404

401mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

405mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

402−mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph = do

406+mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do

403 let transactionForHeadErr name = case transactionForHead name graph of

407 let transactionForHeadErr name = case transactionForHead name graph of

404 Nothing -> Left (NoSuchHeadNameError name)

408 Nothing -> Left (NoSuchHeadNameError name)

405 Just t -> Right t

409 Just t -> Right t

@@ -409,16 +413,16 @@ mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) grap

409 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)

413 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)

410 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

414 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

411 subGraph' <- filterSubGraph subGraph subHeads

415 subGraph' <- filterSubGraph subGraph subHeads

412− case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of

416+ case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of

413 Left err -> Left (MergeTransactionError err)

417 Left err -> Left (MergeTransactionError err)

414 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of

418 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of

415 Left err -> Left err

419 Left err -> Left err

416 Right _ -> case headNameForTransaction disconParent graph of

420 Right _ -> case headNameForTransaction disconParent graph of

417 Nothing -> Left (TransactionIsNotAHeadError parentId)

421 Nothing -> Left (TransactionIsNotAHeadError parentId)

418 Just headName -> do

422 Just headName -> do

419− (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans ??? graph

423+ (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph

420 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)

424 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)

421− newDiscon = DisconnectedTransaction newId (schemas newTrans) False

425+ newDiscon = Discon.freshTransaction newId (schemas newTrans)

422 pure (newDiscon, newGraph')

426 pure (newDiscon, newGraph')

423

427

424--TEMPORARY COPY/PASTE

428--TEMPORARY COPY/PASTE

@@ -426,7 +430,7 @@ showTransactionStructureX :: Transaction -> TransactionGraph -> String

426showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo

430showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo

427 where

431 where

428 headInfo = maybe "" show (headNameForTransaction trans graph)

432 headInfo = maybe "" show (headNameForTransaction trans graph)

429− parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of

433+ parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of

430 Left err -> show err

434 Left err -> show err

431 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet

435 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet

432

436

@@ -446,7 +450,7 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

446

450

447--helper function for commonalities in union merge

451--helper function for commonalities in union merge

448createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

452createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

449−createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do

453+createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do

450 let contextA = concreteDatabaseContext t1

454 let contextA = concreteDatabaseContext t1

451 contextB = concreteDatabaseContext t2

455 contextB = concreteDatabaseContext t2

452

456

@@ -474,7 +478,10 @@ createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do

474 typeConstructorMapping = types

478 typeConstructorMapping = types

475 }

479 }

476 newSchemas = Schemas newContext (subschemas t1)

480 newSchemas = Schemas newContext (subschemas t1)

477− pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) TD.empty stamp) newSchemas)

481+ pure (Transaction newId (TransactionInfo {

482+ parents = NE.fromList [(transactionId t1, undefined),

483+ (transactionId t2, undefined)],

484+ stamp = stamp'}) newSchemas)

478

485

479lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

486lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

480lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

487lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -491,11 +498,11 @@ backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrac

491-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily

498-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily

492backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

499backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

493 trans <- transactionForId currentTid graph

500 trans <- transactionForId currentTid graph

494− let parents = S.toAscList (transactionParentIds trans)

501+ let parentIds' = S.toList (parentIds trans)

495− if length parents < 1 then

502+ if length parentIds' < 1 then

496 Left RootTransactionTraversalError

503 Left RootTransactionTraversalError

497 else do

504 else do

498− parentTrans <- transactionForId (head parents) graph

505+ parentTrans <- transactionForId (head parentIds') graph

499 if steps == 1 then

506 if steps == 1 then

500 pure (transactionId parentTrans)

507 pure (transactionId parentTrans)

501 else

508 else

@@ -503,44 +510,44 @@ backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

503

510

504backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

511backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

505 trans <- transactionForId currentTid graph

512 trans <- transactionForId currentTid graph

506− let parents = transactionParentIds trans

513+ let parentIds' = parentIds trans

507− if S.size parents < 1 then

514+ if S.size parentIds' < 1 then

508 Left RootTransactionTraversalError

515 Left RootTransactionTraversalError

509− else if S.size parents < steps then

516+ else if S.size parentIds' < steps then

510− Left (ParentCountTraversalError (S.size parents) steps)

517+ Left (ParentCountTraversalError (S.size parentIds') steps)

511 else

518 else

512− pure (S.elemAt (steps - 1) parents)

519+ pure (S.elemAt (steps - 1) parentIds')

513

520

514−backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp) = do

521+backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do

515 trans <- transactionForId currentTid graph

522 trans <- transactionForId currentTid graph

516− let parents = transactionParentIds trans

523+ let parentIds' = parentIds trans

517− if transactionTimestamp trans <= stamp then

524+ if timestamp trans <= stamp' then

518 pure currentTid

525 pure currentTid

519− else if S.null parents then

526+ else if S.null parentIds' then

520 Left RootTransactionTraversalError

527 Left RootTransactionTraversalError

521 else

528 else

522− let arbitraryParent = head (S.toList parents) in

529+ let arbitraryParent = head (S.toList parentIds') in

523 backtrackGraph graph arbitraryParent btrack

530 backtrackGraph graph arbitraryParent btrack

524

531

525-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.

532-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.

526--this is not a GraphOp because it combines multiple graph operations

533--this is not a GraphOp because it combines multiple graph operations

527autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

534autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

528−autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do

535+autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do

529 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId

536 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId

530 --create the temp branch

537 --create the temp branch

531− (discon', graph') <- evalGraphOp stamp tempBranchTransId discon graph (Branch tempBranchName)

538+ (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)

532

539

533 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type

540 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type

534− (discon'', graph'') <- evalGraphOp stamp tempCommitTransId discon' graph' Commit

541+ (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit

535

542

536 --jump to merge head

543 --jump to merge head

537− (discon''', graph''') <- evalGraphOp stamp tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)

544+ (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)

538

545

539 --create the merge

546 --create the merge

540− (discon'''', graph'''') <- evalGraphOp stamp mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)

547+ (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)

541

548

542 --delete the temp branch

549 --delete the temp branch

543− (discon''''', graph''''') <- evalGraphOp stamp tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)

550+ (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)

544 {-

551 {-

545 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')

552 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')

546 traceShowM rel

553 traceShowM rel

src/lib/ProjectM36/TransactionGraph/Persist.hs+6−5

@@ -24,7 +24,7 @@ import Control.Exception.Base

24import qualified Data.ByteString as BS

25import qualified Data.Text.Encoding as TE

26import Data.ByteString (ByteString)

27−import Data.Monoid

27+--import Data.Monoid

28import qualified Crypto.Hash.SHA256 as SHA256

29import Control.Arrow

30import Data.Time.Clock

@@ -192,12 +192,12 @@ writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = w

192 uuidInfo = T.intercalate "\n" graphLines

193 digest = SHA256.hash (encodeUtf8 uuidInfo)

194 graphLines = S.toList $ S.map graphLine transSet

195− epochTime = realToFrac . utcTimeToPOSIXSeconds . transactionTimestamp :: Transaction -> Double

195+ epochTime = realToFrac . utcTimeToPOSIXSeconds . timestamp :: Transaction -> Double

196 graphLine trans = U.toText (transactionId trans)

197 <> " "

198 <> T.pack (show (epochTime trans))

199 <> " "

200− <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))

200+ <> T.intercalate " " (S.toList (S.map U.toText $ parentIds trans))

201

202readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

203readGraphTransactionIdFileDigest dbdir = do

@@ -207,8 +207,8 @@ readGraphTransactionIdFileDigest dbdir = do

207readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

208readGraphTransactionIdFile dbdir = do

209 --read in all transactions' uuids

210− let grapher line = let tid:epochText:parentIds = T.words line in

210+ let grapher line = let tid:epochText:parentIds' = T.words line in

211− (readUUID tid, readEpoch epochText, map readUUID parentIds)

211+ (readUUID tid, readEpoch epochText, map readUUID parentIds')

212 readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)

213 readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))

214 Right . map grapher . T.lines <$> readUTF8FileOrError (transactionLogPath dbdir)

@@ -223,3 +223,4 @@ readUTF8FileOrError pathIn = do

223 case TE.decodeUtf8' fileBytes of

224 Left err -> error (show err)

225 Right utf8Bytes -> pure utf8Bytes

226+

src/lib/ProjectM36/TransactionGraph/Show.hs+3−4

@@ -1,17 +1,16 @@

1module ProjectM36.TransactionGraph.Show where

2import ProjectM36.Base

3import ProjectM36.TransactionGraph

4−import ProjectM36.Transaction

5import qualified Data.Set as S

4import qualified Data.Set as S

7showTransactionStructure :: Transaction -> TransactionGraph -> String

6showTransactionStructure :: Transaction -> TransactionGraph -> String

8−showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " p" ++ parentTransactionsInfo ++ " c" ++ childTransactionsInfo

7+showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " p" ++ parentTransactionsInfo

9 where

8 where

10 headInfo = maybe "" show (headNameForTransaction trans graph)

9 headInfo = maybe "" show (headNameForTransaction trans graph)

11− parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of

10+ parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of

12 Left err -> show err

11 Left err -> show err

13 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet

12 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet

14− childTransactionsInfo = show (S.toList (transactionChildIds trans))

13+

16showGraphStructure :: TransactionGraph -> String

15showGraphStructure :: TransactionGraph -> String

17showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet

16showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet

src/lib/ProjectM36/Tupleable.hs+1−1

@@ -10,7 +10,7 @@ module ProjectM36.Tupleable where

10import Data.Foldable

11import Data.List (partition)

12import qualified Data.Map as Map

13−import Data.Monoid

13+--import Data.Monoid

14import Data.Proxy

15import qualified Data.Text as T

16import qualified Data.Vector as V