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

git.iko.soy/project-m36

on master help sign in

add :showGraph to tutd console

18de5feAgentM12 years ago

Relation.hs+1−1

compare with master

unifiedsplit

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

232 let remappedTuple = mapper tupleIn

233 if tupleAttributes remappedTuple == tupleAttributes tupleIn

234 then Right remappedTuple

235− else Left $ TupleAttributeTypeMismatchError 0

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

236

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

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

RelationAttribute.hs+11

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

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

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

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)

41validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

42validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)

43 | HS.null invalidSet = Right rel

44− | otherwise = Left (TupleAttributeTypeMismatchError 0)

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

45 where

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

47 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of

RelationTupleSet.hs+2−1

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

1module RelationTupleSet where

2import RelationType

3import RelationTuple

4+import RelationAttribute

4import RelationalError

5import RelationalError

5import qualified Data.Map as M

6import qualified Data.Map as M

6import qualified Data.HashSet as HS

7import qualified Data.HashSet as HS

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

20 verifyTuple tuple = if tupleAttributes tuple == attrs then

21 verifyTuple tuple = if tupleAttributes tuple == attrs then

21 Right tuple

22 Right tuple

22 else

23 else

23− Left $ TupleAttributeTypeMismatchError 0

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

RelationalError.hs+4−2

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

1module RelationalError where

2import RelationType

3import qualified Data.UUID as U

4+import qualified Data.Set as S

5data RelationalError = NoSuchAttributeNameError String

7data RelationalError = NoSuchAttributeNameError String

6− | TupleAttributeCountMismatchError Int

8+ | TupleAttributeCountMismatchError Int --attribute name

7− | TupleAttributeTypeMismatchError Int

9+ | TupleAttributeTypeMismatchError Attributes

8 | AttributeCountMismatchError Int

10 | AttributeCountMismatchError Int

9 | AttributeNameMismatchError String

11 | AttributeNameMismatchError String

10 | AttributeNameInUseError AttributeName

12 | AttributeNameInUseError AttributeName

RelationalTransaction.hs−12

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

134 err:xs -> Just err

135 _ -> Nothing

136

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

8import RelationExpr

9import RelationTerm

10import RelationalTransaction

11+import RelationalTransactionShow

11import Text.Parsec

12import Text.Parsec

12import Text.Parsec.String

13import Text.Parsec.String

13import Text.Parsec.Expr

14import Text.Parsec.Expr

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

25import qualified Data.UUID as U

26import qualified Data.UUID as U

26import Data.UUID.V4 (nextRandom)

27import Data.UUID.V4 (nextRandom)

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+-}

28lexer :: Token.TokenParser ()

44lexer :: Token.TokenParser ()

29lexer = Token.makeTokenParser tutD

45lexer = Token.makeTokenParser tutD

30 where tutD = emptyDef {

46 where tutD = emptyDef {

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

260 Branch :: HeadName -> GraphOperator

276 Branch :: HeadName -> GraphOperator

261 Commit :: GraphOperator

277 Commit :: GraphOperator

262 Rollback :: GraphOperator

278 Rollback :: GraphOperator

279+ ShowGraph :: GraphOperator

263 deriving (Show)

280 deriving (Show)

264

281

265typeP :: Parser ContextOperator

282typeP :: Parser ContextOperator

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

270

287

271showRelP :: Parser ContextOperator

288showRelP :: Parser ContextOperator

272showRelP = do

289showRelP = do

273− reservedOp ":show"

290+ reservedOp ":showExpr"

274 expr <- relExpr

291 expr <- relExpr

275 return $ ShowRelation expr

292 return $ ShowRelation expr

276

293

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

313 reservedOp ":rollback"

330 reservedOp ":rollback"

314 return $ Rollback

331 return $ Rollback

315

332

333+showGraphP :: Parser GraphOperator

334+showGraphP = do

335+ reservedOp ":showGraph"

336+ return $ ShowGraph

337+

316transactionGraphOps = do

338transactionGraphOps = do

317 jumpToHeadP

339 jumpToHeadP

318 <|> jumpToTransactionP

340 <|> jumpToTransactionP

319 <|> branchTransactionP

341 <|> branchTransactionP

320 <|> commitTransactionP

342 <|> commitTransactionP

321 <|> rollbackTransactionP

343 <|> rollbackTransactionP

344+ <|> showGraphP

322

345

323contextOps :: Parser ContextOperator

346contextOps :: Parser ContextOperator

324contextOps = typeP

347contextOps = typeP

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

341data TutorialDOperatorResult = QuitResult |

364data TutorialDOperatorResult = QuitResult |

342 DisplayResult String |

365 DisplayResult String |

343 DisplayErrorResult String |

366 DisplayErrorResult String |

367+ QuietSuccessResult |

344 NoActionResult

368 NoActionResult

345

369

346evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

370evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

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

366

390

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

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

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

392-- 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)

370

394

371--affects only disconncted transaction

395--affects only disconncted transaction

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

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

373 Left err -> Left err

397 Left err -> Left err

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

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

375 where

399 where

376 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

400 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

377

401

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

380evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =

404evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =

381 case transactionForHead headName graph of

405 case transactionForHead headName graph of

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

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

383− Right (disconnectedTrans, graph)

407+ Right (disconnectedTrans, graph, QuietSuccessResult)

384 Nothing -> Left $ NoSuchHeadNameError headName

408 Nothing -> Left $ NoSuchHeadNameError headName

385-- add new head pointing to branchPoint

409-- add new head pointing to branchPoint

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

410-- 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

401 Left err -> Left err

425 Left err -> Left err

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

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

403 Left err -> Left err

427 Left err -> Left err

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

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

405 where

429 where

406 newDiscon = DisconnectedTransaction newUUID disconContext

430 newDiscon = DisconnectedTransaction newUUID disconContext

407

431

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

413 Nothing -> Left $ TransactionIsNotAHeadError parentUUID

437 Nothing -> Left $ TransactionIsNotAHeadError parentUUID

414 Just headName -> case maybeUpdatedGraph of

438 Just headName -> case maybeUpdatedGraph of

415 Left err-> Left err

439 Left err-> Left err

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

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

417 where

441 where

418 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

442 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

419 --parentTransaction = transactionForUUID parentUUID graph

443 --parentTransaction = transactionForUUID parentUUID graph

420 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph

444 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph

421

445

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

446-- 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

424 Left err -> Left err

448 Left err -> Left err

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

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

426 where

450 where

427 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)

451 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)

428

457

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

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

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

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

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

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

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

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

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

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

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

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

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

444

473

445promptText :: DisconnectedTransaction -> TransactionGraph -> String

474promptText :: DisconnectedTransaction -> TransactionGraph -> String

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

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