6dbd0b1 · project-m36 · git.iko.soy

git.iko.soy/project-m36

add trans graph relational expression head lookup backtracking ala git (~/^)

commit6dbd0b18040f953fc9ff55c2b109ce8d39390d3c authorAgentM <agentm@themactionfaction.com> dateWed 7 Sep 2016, 17:45 (10 years ago) parent69e7485

5 files changed+59−10

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+10−1 src/lib/ProjectM36/Client.hs+2 src/lib/ProjectM36/Error.hs+1 src/lib/ProjectM36/TransactionGraph.hs+37−6 test/TutorialD/Interpreter.hs+9−3

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+10−1

@@ -20,8 +20,17 @@ data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalE

2020

2121transactionIdLookupP :: Parser TransactionIdLookup

2222transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>

23− (TransactionIdHeadNameLookup <$> identifier)

23+ (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP)

2424

25+transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack

26+transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>

27+ (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP))

28+

29+backtrackP :: Parser Int

30+backtrackP = do

31+ steps <- integer <|> pure 1

32+ pure (fromIntegral steps)

33+

2534transGraphRelationalOpP :: Parser TransGraphRelationalOperator

2635transGraphRelationalOpP = showTransGraphRelationalOpP

2736

src/lib/ProjectM36/Client.hs+2

@@ -42,6 +42,8 @@ module ProjectM36.Client

4242 RelationCardinality(..),

4343 TransactionGraphOperator(..),

4444 TransGraphRelationalExpr,

45+ TransactionIdLookup(..),

46+ TransactionIdHeadBacktrack(..),

4547 NodeId(..),

4648 Atom(..),

4749 Session,

src/lib/ProjectM36/Error.hs+1

@@ -31,6 +31,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3131 | HeadNameSwitchingHeadProhibitedError HeadName

3232 | NoSuchHeadNameError HeadName

3333 | NewTransactionMayNotHaveChildrenError TransactionId

34+ | ParentCountTraversalError Int Int --maximum, requested

3435 | NewTransactionMissingParentError TransactionId

3536 | TransactionIsNotAHeadError TransactionId

3637 | TransactionGraphCycleError TransactionId

src/lib/ProjectM36/TransactionGraph.hs+37−6

@@ -21,12 +21,13 @@ import Data.Either (lefts, rights, isRight)

2121

2222-- | Record a lookup for a specific transaction in the graph.

2323data TransactionIdLookup = TransactionIdLookup TransactionId |

24− TransactionIdHeadNameLookup HeadName

24+ TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

2525 deriving (Show, Eq, Binary, Generic)

2626

2727-- topic~3^2

28−data TransactionIdHeadBacktrack = TransactionIdHeadParentBackTrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

29− TransactionIdHeadBranchBackTrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent

28+data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

29+ TransactionIdHeadBranchBacktrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent

30+ deriving (Show, Eq, Binary, Generic)

3031

3132--operators which manipulate a transaction graph

3233data TransactionGraphOperator = JumpToHead HeadName |

@@ -422,6 +423,36 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

422423

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

424425lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

425−lookupTransaction graph (TransactionIdHeadNameLookup headName) = case transactionForHead headName graph of

426− Just t -> Right t

427− Nothing -> Left (NoSuchHeadNameError headName)

426+lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of

427+ Nothing -> Left (NoSuchHeadNameError headName)

428+ Just headTrans -> do

429+ traversedId <- traverseGraph graph (transactionId headTrans) backtracks

430+ transactionForId traversedId graph

431+

432+traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId

433+traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps

434+

435+backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId

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

437+backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

438+ trans <- transactionForId currentTid graph

439+ let parents = S.toAscList (transactionParentIds trans)

440+ if length parents < 1 then

441+ Left RootTransactionTraversalError

442+ else do

443+ parentTrans <- transactionForId (head parents) graph

444+ if steps == 1 then do

445+ pure (transactionId parentTrans)

446+ else

447+ backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))

448+

449+backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

450+ trans <- transactionForId currentTid graph

451+ let parents = transactionParentIds trans

452+ if S.size parents < 1 then

453+ Left RootTransactionTraversalError

454+ else if S.size parents < steps then

455+ Left (ParentCountTraversalError (S.size parents) steps)

456+ else

457+ pure (S.elemAt (steps - 1) parents)

458+

test/TutorialD/Interpreter.hs+9−3

@@ -308,8 +308,8 @@ testTransGraphRelationalExpr = TestCase $ do

308308 "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",

309309 ":commit"

310310 ]

311− let masterMarker = TransactionIdHeadNameLookup "master"

312− testBranchMarker = TransactionIdHeadNameLookup "testbranch"

311+ let masterMarker = TransactionIdHeadNameLookup "master" []

312+ testBranchMarker = TransactionIdHeadNameLookup "testbranch" []

313313 sattrs = attributesFromList [Attribute "city" TextAtomType,

314314 Attribute "sname" TextAtomType,

315315 Attribute "s#" TextAtomType,

@@ -319,4 +319,10 @@ testTransGraphRelationalExpr = TestCase $ do

319319 TextAtom "S9",

320320 IntAtom 50]]

321321 diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))

322− assertEqual "difference in s" expectedRel diff

322+ assertEqual "difference in s" expectedRel diff

323+

324+ --test graph traversal (head backtracking

325+ let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]

326+ backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))

327+ assertEqual "backtrack to master" (Right relationTrue) backtrackRel

328+