18de5fe · project-m36 · git.iko.soy

git.iko.soy/project-m36

add :showGraph to tutd console

commit18de5fe79df5e0019d6f96725d5de153b7457e35 authorAgentM <agentm@themactionfaction.com> dateThu 16 Apr 2015, 20:14 (12 years ago) parent3335353

8 files changed+114−26

compare with master

unifiedsplit

Relation.hs+1−1 RelationAttribute.hs+11 RelationTest.hs+1−1 RelationTupleSet.hs+2−1 RelationalError.hs+4−2 RelationalTransaction.hs−12 RelationalTransactionShow.hs+57 TutorialDInterpreter.hs+38−9

Relation.hs+1−1

@@ -232,7 +232,7 @@ relMap mapper (Relation attrs tupleSet) = do

232232 let remappedTuple = mapper tupleIn

233233 if tupleAttributes remappedTuple == tupleAttributes tupleIn

234234 then Right remappedTuple

235− else Left $ TupleAttributeTypeMismatchError 0

235+ else Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tupleIn) attrs)

236236

237237--in the future, the mapper should be able to return a RelationalError likely

238238relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

RelationAttribute.hs+11

@@ -33,3 +33,14 @@ matchingAttributeNameSet = S.intersection

3333-- this is sorted so the tuples know in which order to output- the ordering is arbitrary

3434sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet

3535

36+-- take two attribute sets and return an attribute set with the attributes which do not match

37+attributesDifference :: Attributes -> Attributes -> Attributes

38+attributesDifference attrA attrB = M.union mismatchA missingB

39+ where

40+ mismatchA = M.foldrWithKey folder M.empty attrA

41+ missingB = M.difference attrA attrB

42+ folder :: AttributeName -> Attribute -> Attributes -> Attributes

43+ folder attrName attrinA acc = if M.notMember attrName attrB || M.lookup attrName attrB /= Just attrinA then

44+ M.insert attrName attrinA acc

45+ else

46+ acc

RelationTest.hs+1−1

@@ -41,7 +41,7 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)

4141validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

4242validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)

4343 | HS.null invalidSet = Right rel

44− | otherwise = Left (TupleAttributeTypeMismatchError 0)

44+ | otherwise = Left (TupleAttributeTypeMismatchError M.empty) --fix to include invalid attrs

4545 where

4646 tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap

4747 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of

RelationTupleSet.hs+2−1

@@ -1,6 +1,7 @@

11module RelationTupleSet where

22import RelationType

33import RelationTuple

4+import RelationAttribute

45import RelationalError

56import qualified Data.Map as M

67import qualified Data.HashSet as HS

@@ -20,4 +21,4 @@ verifyRelationTupleSet attrs tupleSet = do

2021 verifyTuple tuple = if tupleAttributes tuple == attrs then

2122 Right tuple

2223 else

23− Left $ TupleAttributeTypeMismatchError 0

24+ Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tuple) attrs)

RelationalError.hs+4−2

@@ -1,10 +1,12 @@

11module RelationalError where

22import RelationType

33import qualified Data.UUID as U

4+import qualified Data.Set as S

57data RelationalError = NoSuchAttributeNameError String

6− | TupleAttributeCountMismatchError Int

7− | TupleAttributeTypeMismatchError Int

8+ | TupleAttributeCountMismatchError Int --attribute name

9+ | TupleAttributeTypeMismatchError Attributes

810 | AttributeCountMismatchError Int

911 | AttributeNameMismatchError String

1012 | AttributeNameInUseError AttributeName

RelationalTransaction.hs−12

@@ -134,15 +134,3 @@ walkChildTransactions seenTransSet graph trans =

134134 err:xs -> Just err

135135 _ -> Nothing

136136

137−showTransactionStructure :: Transaction -> TransactionGraph -> String

138−showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

139− where

140− headInfo = maybe "" show (headNameForTransaction trans graph)

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

142− Left err -> show err

143− Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet

144−

145−showGraphStructure :: TransactionGraph -> String

146−showGraphStructure graph@(TransactionGraph heads transSet) = S.foldr folder "" transSet

147− where

148− folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"

RelationalTransactionShow.hsnew file+57

@@ -0,0 +1,57 @@

1+module RelationalTransactionShow where

2+import RelationType

3+import Relation

4+import RelationTuple

5+import RelationTupleSet

6+import RelationalError

7+import RelationalTransaction

8+import qualified Data.Map as M

9+import qualified Data.HashSet as HS

10+import qualified Data.Set as S

11+

12+showTransactionStructure :: Transaction -> TransactionGraph -> String

13+showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

14+ where

15+ headInfo = maybe "" show (headNameForTransaction trans graph)

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

17+ Left err -> show err

18+ Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet

19+

20+showGraphStructure :: TransactionGraph -> String

21+showGraphStructure graph@(TransactionGraph heads transSet) = S.foldr folder "" transSet

22+ where

23+ folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"

24+

25+--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction

26+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation

27+graphAsRelation discon@(DisconnectedTransaction parentUUID _) graph@(TransactionGraph heads transSet) = do

28+ tupleSet <- mapM tupleGenerator (S.toList transSet)

29+ mkRelation attributes (HS.fromList tupleSet)

30+ where

31+ attributes = M.fromList [("id", Attribute "id" StringAtomType),

32+ ("parents", Attribute "parents" (RelationAtomType parentAttributes)),

33+ ("current", Attribute "current" IntAtomType)

34+ ]

35+ parentAttributes = M.fromList [("id", Attribute "id" StringAtomType)]

36+ tupleGenerator transaction = case transactionParentsRelation transaction graph of

37+ Left err -> Left err

38+ Right parentTransRel -> Right $ mkRelationTuple (S.fromList ["id", "parents", "current"]) $

39+ (M.fromList

40+ [("id", StringAtom $ show (transactionUUID transaction)),

41+ ("parents", RelationAtom parentTransRel),

42+ ("current", IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0)])

43+

44+transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation

45+transactionParentsRelation trans graph = do

46+ if isRootTransaction trans graph then do

47+ mkRelation attributes emptyTupleSet

48+ else do

49+ parentTransSet <- parentTransactions trans graph

50+ let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)

51+ mkRelation attributes tupleSet

52+ where

53+ attributes = M.fromList [("id", Attribute "id" StringAtomType)]

54+ trans2tuple trans = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans))

55+

56+

57+

TutorialDInterpreter.hs+38−9

@@ -8,6 +8,7 @@ import RelationalError

88import RelationExpr

99import RelationTerm

1010import RelationalTransaction

11+import RelationalTransactionShow

1112import Text.Parsec

1213import Text.Parsec.String

1314import Text.Parsec.Expr

@@ -25,6 +26,21 @@ import System.Directory (getHomeDirectory)

2526import qualified Data.UUID as U

2627import Data.UUID.V4 (nextRandom)

2728

29+{-

30+List of Tutorial D operators:

31+show relation expression type :: relexpr -> context -> opresult

32+show relvar :: relvar name -> context -> opresult

33+quit :: ()

34+show graph :: graph -> DisconnectedTransaction -> opresult

35+show constraints :: context -> opresult

36+jump to head :: head name -> graph -> DisconnectedTransaction (graph unchanged)

37+jump to UUID :: uuid -> graph -> DisconnectedTransaction (graph unchanged)

38+branch :: uuid -> branch name -> graph -> (DisconnectedTransation, graph)

39+commit :: uuid -> DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)

40+rollback :: DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)

41+

42+

43+-}

2844lexer :: Token.TokenParser ()

2945lexer = Token.makeTokenParser tutD

3046 where tutD = emptyDef {

@@ -260,6 +276,7 @@ data GraphOperator where

260276 Branch :: HeadName -> GraphOperator

261277 Commit :: GraphOperator

262278 Rollback :: GraphOperator

279+ ShowGraph :: GraphOperator

263280 deriving (Show)

264281

265282typeP :: Parser ContextOperator

@@ -270,7 +287,7 @@ typeP = do

270287

271288showRelP :: Parser ContextOperator

272289showRelP = do

273− reservedOp ":show"

290+ reservedOp ":showExpr"

274291 expr <- relExpr

275292 return $ ShowRelation expr

276293

@@ -313,12 +330,18 @@ rollbackTransactionP = do

313330 reservedOp ":rollback"

314331 return $ Rollback

315332

333+showGraphP :: Parser GraphOperator

334+showGraphP = do

335+ reservedOp ":showGraph"

336+ return $ ShowGraph

337+

316338transactionGraphOps = do

317339 jumpToHeadP

318340 <|> jumpToTransactionP

319341 <|> branchTransactionP

320342 <|> commitTransactionP

321343 <|> rollbackTransactionP

344+ <|> showGraphP

322345

323346contextOps :: Parser ContextOperator

324347contextOps = typeP

@@ -341,6 +364,7 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu

341364data TutorialDOperatorResult = QuitResult |

342365 DisplayResult String |

343366 DisplayErrorResult String |

367+ QuietSuccessResult |

344368 NoActionResult

345369

346370evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

@@ -366,12 +390,12 @@ evalContextOp context (Quit) = QuitResult

366390

367391-- returns the new "current" transaction, updated graph, and tutorial d result

368392-- the current transaction is not part of the transaction graph until it is committed

369−evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

393+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)

370394

371395--affects only disconncted transaction

372396evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of

373397 Left err -> Left err

374− Right parentTrans -> Right (newTrans, graph)

398+ Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)

375399 where

376400 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

377401

@@ -380,7 +404,7 @@ evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionF

380404evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =

381405 case transactionForHead headName graph of

382406 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in

383− Right (disconnectedTrans, graph)

407+ Right (disconnectedTrans, graph, QuietSuccessResult)

384408 Nothing -> Left $ NoSuchHeadNameError headName

385409-- add new head pointing to branchPoint

386410-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)

@@ -401,7 +425,7 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr

401425 Left err -> Left err

402426 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of

403427 Left err -> Left err

404− Right (newTrans, newGraph) -> Right (newDiscon, newGraph)

428+ Right (newTrans, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)

405429 where

406430 newDiscon = DisconnectedTransaction newUUID disconContext

407431

@@ -413,18 +437,23 @@ evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) gra

413437 Nothing -> Left $ TransactionIsNotAHeadError parentUUID

414438 Just headName -> case maybeUpdatedGraph of

415439 Left err-> Left err

416− Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

440+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)

417441 where

418442 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

419443 --parentTransaction = transactionForUUID parentUUID graph

420444 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph

421445

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

423−evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of

447+evalGraphOp _ discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of

424448 Left err -> Left err

425− Right parentTransaction -> Right (newDiscon, graph)

449+ Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)

426450 where

427451 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)

452+

453+--display transaction graph as relation

454+evalGraphOp _ discon graph ShowGraph = do

455+ graphStr <- graphAsRelation discon graph

456+ return (discon, graph, DisplayResult $ showRelation graphStr)

428457

429458--shouldn't this be Either RelationalError DatabaseContext?

430459interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)

@@ -440,7 +469,7 @@ interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGra

440469 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))

441470 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of

442471 Left err -> (trans, transGraph, DisplayErrorResult $ show err)

443− Right (newDiscon, newGraph) -> (newDiscon, newGraph, DisplayResult "Done.")

472+ Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)

444473

445474promptText :: DisconnectedTransaction -> TransactionGraph -> String

446475promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "